~ chicken-core (master) /r7lib.scm

  1;;;; r7lib.scm - R7RS library code
  2;
  3; Copyright (c) 2022, The CHICKEN Team
  4; All rights reserved.
  5;
  6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  7; conditions are met:
  8;
  9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 10;     disclaimer.
 11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 12;     disclaimer in the documentation and/or other materials provided with the distribution.
 13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 14;     products derived from this software without specific prior written permission.
 15;
 16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 24; POSSIBILITY OF SUCH DAMAGE.
 25
 26(declare
 27  (unit r7lib)
 28  (disable-interrupts))
 29
 30(include "common-declarations.scm")
 31
 32(module scheme.write (display
 33		      write
 34		      write-shared
 35		      write-simple)
 36  (import (rename scheme (display display-simple) (write write-simple))
 37	  (only chicken.base foldl when optional)
 38	  (only chicken.fixnum fx+ fx- fx= fx<= fx>= fx> fx-))
 39
 40  (define (interesting? o)
 41    (or (pair? o)
 42	(and (vector? o)
 43	     (fx<= 1 (##sys#size o)))))
 44
 45  (define (uninteresting? o)
 46    (not (interesting? o)))
 47
 48  (define (emit str p)
 49    (let ((bv (##sys#slot str 0)))
 50      ((##sys#slot (##sys#slot p 2) 3) p bv 0 (fx- (##sys#size bv) 1))))  ; write-bytevector
 51
 52  (define (display-char c p)
 53    (let ((n (##sys#print-length-limit)))
 54      (when n
 55        (let ((pl (##sys#current-print-length)))
 56          (##sys#current-print-length (fx+ pl 1))
 57          (when (fx> pl n)
 58            (emit "..." p)
 59            ((##sys#print-exit) (##sys#void)))))
 60      ((##sys#slot (##sys#slot p 2) 2) p c)))   ; write-char
 61
 62  (define (display-string s p)
 63    (let ((n (##sys#print-length-limit)))
 64      (if n
 65          (let* ((len (string-length s))
 66                 (pl (##sys#current-print-length))
 67                 (pl2 (fx+ pl len)))
 68            (if (fx> pl2 n)
 69                (let ((m (fx- n pl2)))
 70                  (when (fx> m 0) (emit (##sys#substring s 0 m) p))
 71                  (emit "..." p)
 72                  ((##sys#print-exit) (##sys#void)))
 73                (emit s p))
 74            (##sys#current-print-length pl2))
 75          (emit s p))))
 76
 77  ;; Build an alist mapping `interesting?` objects to boolean values
 78  ;; indicating whether those objects occur shared in `o`.
 79  (define (find-shared o cycles-only?)
 80
 81    (define seen '())
 82    (define (seen? x) (assq x seen))
 83    (define (seen! x) (set! seen (cons (cons x 1) seen)))
 84
 85    ;; Walk the form, tallying the number of times each object is
 86    ;; encountered. This has the effect of filling `seen` with
 87    ;; occurence counts for all objects satisfying `interesting?`.
 88    (let walk! ((o o))
 89      (when (interesting? o)
 90	(cond ((seen? o) =>
 91	       (lambda (p)
 92		 (##sys#setislot p 1 (fx+ (cdr p) 1))))
 93	      ((pair? o)
 94	       (seen! o)
 95	       (walk! (car o))
 96	       (walk! (cdr o)))
 97	      ((vector? o)
 98	       (seen! o)
 99	       (let ((len (##sys#size o)))
100		 (do ((i 0 (fx+ i 1)))
101		     ((fx= i len))
102		   (walk! (##sys#slot o i))))))
103	;; If we're only interested in cycles and this object isn't
104	;; self-referential, discount it (resulting in `write` rather
105	;; than `write-shared` behavior).
106	(when cycles-only?
107	  (let ((p (seen? o)))
108	    (when (fx<= (cdr p) 1)
109	      (##sys#setislot p 1 0))))))
110
111    ;; Mark shared objects #t, unshared objects #f.
112    (foldl (lambda (a p)
113	     (if (fx<= (cdr p) 1)
114		 (cons (cons (car p) #f) a)
115		 (cons (cons (car p) #t) a)))
116	   '()
117	   seen))
118
119  (define (write-with-shared-structure writer obj cycles-only? port)
120
121    (define label 0)
122    (define (assign-label! pair)
123      (##sys#setslot pair 1 label)
124      (set! label (fx+ label 1)))
125
126    (define shared
127      (find-shared obj cycles-only?))
128
129    (define (write-interesting/shared o)
130      (cond ((pair? o)
131	     (display-char #\( port)
132	     (write/shared (car o))
133	     (let loop ((o (cdr o)))
134	       (cond ((null? o)
135		      (display-char #\) port))
136		     ((and (pair? o)
137			   (not (cdr (assq o shared))))
138		      (display-char #\space port)
139		      (write/shared (car o))
140		      (loop (cdr o)))
141		     (else
142		      (display-string " . " port)
143		      (write/shared o)
144		      (display-char #\) port)))))
145	    ((vector? o)
146	     (display-string "#(" port)
147	     (write/shared (##sys#slot o 0))
148	     (let ((len (##sys#size o)))
149	       (do ((i 1 (fx+ i 1)))
150		   ((fx= i len)
151		    (display-char #\) port))
152		 (display-char #\space port)
153		 (write/shared (##sys#slot o i)))))))
154
155    (define (write/shared o)
156      (if (uninteresting? o)
157	  (writer o port)
158	  (let* ((p (assq o shared))
159		 (d (cdr p)))
160	    (cond ((not d)
161		   (write-interesting/shared o))
162		  ((number? d)
163		   (display-char #\# port)
164		   (writer d port)
165		   (display-char #\# port))
166		  (else
167		   (display-char #\# port)
168		   (writer label port)
169		   (display-char #\= port)
170		   (assign-label! p)
171		   (write-interesting/shared o))))))
172
173    (write/shared obj))
174
175  (define (display o #!optional (p ##sys#standard-output))
176    (write-with-shared-structure
177     display-simple
178     o
179     #t
180     p))
181
182  (define (write o  #!optional (p ##sys#standard-output))
183    (write-with-shared-structure
184     write-simple
185     o
186     #t
187     p))
188
189  (define (write-shared o #!optional (p ##sys#standard-output))
190    (write-with-shared-structure
191     write-simple
192     o
193     #f
194     p))
195
196)
197
198(module scheme.time (current-second
199                     current-jiffy
200                     jiffies-per-second)
201  (import (only chicken.base define-constant)
202          (chicken foreign)
203          (only chicken.time current-seconds)
204          (only scheme + define inexact->exact))
205
206  ;; As of 2012-06-30.
207  (define-constant tai-offset 37.)
208
209  (define (current-second) (+ (current-seconds) tai-offset))
210
211  (define current-jiffy (foreign-lambda long "C_current_jiffy"))
212
213  (define jiffies-per-second (foreign-lambda long "C_jiffies_per_second"))
214
215)
216
217(module scheme.file (file-exists? delete-file
218                     open-input-file open-binary-input-file
219                     open-output-file open-binary-output-file
220                     call-with-input-file call-with-output-file
221                     with-input-from-file with-output-to-file)
222  (import (only scheme and define quote let apply open-input-file open-output-file call-with-input-file
223                call-with-output-file with-input-from-file with-output-to-file)
224          (rename (only (chicken file) delete-file file-exists?) (file-exists? file-exists?/base)))
225
226  (define (open-binary-input-file fname . args)
227    (let ((p (apply open-input-file fname #:binary args)))
228      (##sys#setslot p 14 'binary)
229      p))
230
231  (define (open-binary-output-file fname . args)
232    (let ((p (apply open-output-file fname #:binary args)))
233      (##sys#setslot p 14 'binary)
234      p))
235
236  (define (file-exists? fname)
237    (and (file-exists?/base fname) #t))
238
239)
240
241(module scheme.process-context (command-line
242				emergency-exit
243				exit
244				get-environment-variable
245				get-environment-variables)
246  (import scheme
247          chicken.process-context
248          chicken.type
249	  (rename chicken.base (exit chicken-exit)))
250
251(define (command-line)
252  ;; Don't cache these; they may be parameterized at any time!
253  (cons (program-name) (command-line-arguments)))
254
255(define (->exit-status obj)
256  (cond ((integer? obj) obj)
257        ((eq? obj #f) 1)
258        (else 0)))
259
260(define (exit #!optional (obj 0))
261  ;; ##sys#dynamic-unwind is hidden, have to unwind manually.
262  ; (##sys#dynamic-unwind '() (length ##sys#dynamic-winds))
263  (let unwind ()
264    (unless (null? ##sys#dynamic-winds)
265      (let ((after (cdar ##sys#dynamic-winds)))
266        (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
267        (after)
268        (unwind))))
269  ;; The built-in exit runs cleanup handlers for us.
270  (chicken-exit (->exit-status obj)))
271
272)
273