source: project/release/5/slib-prec/trunk/slib-compat.scm @ 38716

Last change on this file since 38716 was 38716, checked in by Kon Lovett, 4 months ago

split grammers, strict-types

File size: 2.9 KB
Line 
1;;;; slib-compat.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '20
3
4(import (only (srfi 1) every last-pair))
5(import (only (chicken port) call-with-output-string))
6(import (only (chicken pretty-print) pretty-print))
7
8(define mod modulo)
9
10(define (cleanup-handlers!) (begin))
11
12(define (find-if . args)
13  (import (only (srfi 1) find))
14  (apply find args) )
15
16(define (remove-if. args)
17  (import (only (srfi 1) remove))
18  (apply remove args) )
19
20(define last)
21(let ()
22  (define (comlist:nthcdr n lst)
23    (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
24  (set! last (lambda (lst n) (comlist:nthcdr (- (length lst) n) lst))) )
25
26;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
27;;; use this definition if your system doesn't have such a procedure.
28(define (force-output . args)
29  (import (only (chicken base) flush-output))
30  (flush-output (if (pair? args) (car args) (current-output-port))))
31
32(define (software-type)
33  (import (only (chicken platform) software-type))
34  (let ((softtype (software-type)))
35    (case softtype
36      ((windows)  'ms-dos)
37      (else       softtype)) ) )
38
39(define output-port-width)
40(define output-port-height)
41(let ()
42  (import (only (chicken port) terminal-size))
43  (set! output-port-width (lambda (port)
44    (let-values (((h w) (terminal-size port)))
45      (if (zero? w) 80 w))))
46  (set! output-port-height (lambda (port)
47    (let-values (((h w) (terminal-size port)))
48      (if (zero? h) 25 h)))) )
49
50(define provided?
51  (let (
52    (+numeric+ '(inexact bignum))
53    (+builtins+ '()) )
54    (lambda (x)
55      (import (only (chicken keyword) string->keyword))
56      (import (only (chicken platform) features))
57      (let (
58        (kwd (string->keyword (symbol->string x)))
59        (fs (features)) )
60        (and
61          (cond
62            ((memq kwd fs))
63            ((and (memq x +numeric+) (memq #:full-numeric-tower fs)))
64            ((memq x +builtins+))
65            (else #f) )
66            #t ) ) ) ) )
67
68(define (require x)
69  ;(print "SLIB require " #\' x)
70  (begin) )
71
72(define (require-if p x)
73  ;(print "SLIB require-if " #\' p " " x)
74  (begin) )
75
76(define (nconc . args)
77  (import (only (srfi 1) concatenate!))
78  (concatenate! args) )
79
80(define (print-call-stack out)
81  (import (only (chicken base) print-call-chain))
82  (print-call-chain out))
83
84(define slib:warn
85  (lambda args
86    (let ((cep (current-error-port)))
87      (if (provided? 'trace) (print-call-stack cep))
88      (display "Warn: " cep)
89      (for-each (lambda (x) (display #\space cep) (write x cep)) args))))
90
91(define slib:error
92  (let ((error error))
93    (lambda args
94      (if (provided? 'trace) (print-call-stack (current-error-port)))
95      (apply error args))))
96
97(define slib:tab #\tab)
98(define slib:form-feed #\page)
99
100(define (math:error . args) (apply slib:error 'math: args))
101(define (math:warn . args)  (apply slib:warn 'math: args))
102(define (math:exit b)       (cleanup-handlers!) (slib:error "error in math system"))
Note: See TracBrowser for help on using the repository browser.