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

Last change on this file since 38563 was 38563, checked in by Kon Lovett, 10 months ago

use slib prec include, use slib simetrix, combine *-setups

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