source: project/release/5/slib-arraymap/tags/1.1.1/slib-compat.scm @ 38723

;;;; slib-compat.scm  -*- scheme -*-
;;;; Kon Lovett, Apr '20

(import (only (srfi 1) every last-pair))
(import (only (chicken port) call-with-output-string))
(import (only (chicken pretty-print) pretty-print))
(import (only (chicken base) let-values identity))

(define mod modulo)

(define (cleanup-handlers!) (begin))

(define (find-if . args)
  (import (only (srfi 1) find))
  (apply find args) )

(define (remove-if. args)
  (import (only (srfi 1) remove))
  (apply remove args) )

(define last)
(let ()
  (define (comlist:nthcdr n lst)
    (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
  (set! last (lambda (lst n) (comlist:nthcdr (- (length lst) n) lst))) )

;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . args)
  (import (only (chicken base) flush-output))
  (flush-output (if (pair? args) (car args) (current-output-port))))

(define (software-type)
  (import (only (chicken platform) software-type))
  (let ((softtype (software-type)))
    (case softtype
      ((windows)  'ms-dos)
      (else       softtype)) ) )

(define output-port-width)
(define output-port-height)
(let ()
  (import (only (chicken port) terminal-size))
  (set! output-port-width (lambda (port)
    (let-values (((h w) (terminal-size port)))
      (if (zero? w) 80 w))))
  (set! output-port-height (lambda (port)
    (let-values (((h w) (terminal-size port)))
      (if (zero? h) 25 h)))) )

(define provided?
  (let (
    (+numeric+ '(inexact bignum))
    (+builtins+ '()) )
    (lambda (x)
      (import (only (chicken keyword) string->keyword))
      (import (only (chicken platform) features))
      (let (
        (kwd (string->keyword (symbol->string x)))
        (fs (features)) )
        (and
          (cond
            ((memq kwd fs))
            ((and (memq x +numeric+) (memq #:full-numeric-tower fs)))
            ((memq x +builtins+))
            (else #f) )
            #t ) ) ) ) )

(define (require x)
  ;(print "SLIB require " #\' x)
  (begin) )

(define (require-if p x)
  ;(print "SLIB require-if " #\' p " " x)
  (begin) )

(define (nconc . args)
  (import (only (srfi 1) concatenate!))
  (concatenate! args) )

(define (print-call-stack out)
  (import (only (chicken base) print-call-chain))
  (print-call-chain out) )

(define (slib:warn args)
  (import (only (chicken base) current-error-port))
  (let ((cep (current-error-port)))
    (if (provided? 'trace) (print-call-stack cep))
    (display "Warn: " cep)
    (for-each (lambda (x) (display #\space cep) (write x cep)) args) ) )

(define slib:error)
(let ()
  (import (only (chicken base) error))
  (let ((error error))
    (set! slib:error (lambda args
      (import (only (chicken base) current-error-port))
      (if (provided? 'trace) (print-call-stack (current-error-port)))
      (apply error args))) ) )

(define slib:tab #\tab)
(define slib:form-feed #\page)

(define (math:error . args) (apply slib:error 'math: args))
(define (math:warn . args)  (apply slib:warn 'math: args))
(define (math:exit b)       (cleanup-handlers!) (slib:error "error in math system"))