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

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

add common slib-compat

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