~ 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-))
 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 (display-char c p)
 49    ((##sys#slot (##sys#slot p 2) 2) p c))
 50
 51  (define (display-string s p)
 52    (let ((bv (##sys#slot s 0)))
 53      ((##sys#slot (##sys#slot p 2) 3) p bv 0 (fx- (##sys#size bv) 1))))
 54
 55  ;; Build an alist mapping `interesting?` objects to boolean values
 56  ;; indicating whether those objects occur shared in `o`.
 57  (define (find-shared o cycles-only?)
 58
 59    (define seen '())
 60    (define (seen? x) (assq x seen))
 61    (define (seen! x) (set! seen (cons (cons x 1) seen)))
 62
 63    ;; Walk the form, tallying the number of times each object is
 64    ;; encountered. This has the effect of filling `seen` with
 65    ;; occurence counts for all objects satisfying `interesting?`.
 66    (let walk! ((o o))
 67      (when (interesting? o)
 68	(cond ((seen? o) =>
 69	       (lambda (p)
 70		 (##sys#setslot p 1 (fx+ (cdr p) 1))))
 71	      ((pair? o)
 72	       (seen! o)
 73	       (walk! (car o))
 74	       (walk! (cdr o)))
 75	      ((vector? o)
 76	       (seen! o)
 77	       (let ((len (##sys#size o)))
 78		 (do ((i 0 (fx+ i 1)))
 79		     ((fx= i len))
 80		   (walk! (##sys#slot o i))))))
 81	;; If we're only interested in cycles and this object isn't
 82	;; self-referential, discount it (resulting in `write` rather
 83	;; than `write-shared` behavior).
 84	(when cycles-only?
 85	  (let ((p (seen? o)))
 86	    (when (fx<= (cdr p) 1)
 87	      (##sys#setslot p 1 0))))))
 88
 89    ;; Mark shared objects #t, unshared objects #f.
 90    (foldl (lambda (a p)
 91	     (if (fx<= (cdr p) 1)
 92		 (cons (cons (car p) #f) a)
 93		 (cons (cons (car p) #t) a)))
 94	   '()
 95	   seen))
 96
 97  (define (write-with-shared-structure writer obj cycles-only? port)
 98
 99    (define label 0)
100    (define (assign-label! pair)
101      (##sys#setslot pair 1 label)
102      (set! label (fx+ label 1)))
103
104    (define shared
105      (find-shared obj cycles-only?))
106
107    (define (write-interesting/shared o)
108      (cond ((pair? o)
109	     (display-char #\( port)
110	     (write/shared (car o))
111	     (let loop ((o (cdr o)))
112	       (cond ((null? o)
113		      (display-char #\) port))
114		     ((and (pair? o)
115			   (not (cdr (assq o shared))))
116		      (display-char #\space port)
117		      (write/shared (car o))
118		      (loop (cdr o)))
119		     (else
120		      (display-string " . " port)
121		      (write/shared o)
122		      (display-char #\) port)))))
123	    ((vector? o)
124	     (display-string "#(" port)
125	     (write/shared (##sys#slot o 0))
126	     (let ((len (##sys#size o)))
127	       (do ((i 1 (fx+ i 1)))
128		   ((fx= i len)
129		    (display-char #\) port))
130		 (display-char #\space port)
131		 (write/shared (##sys#slot o i)))))))
132
133    (define (write/shared o)
134      (if (uninteresting? o)
135	  (writer o port)
136	  (let* ((p (assq o shared))
137		 (d (cdr p)))
138	    (cond ((not d)
139		   (write-interesting/shared o))
140		  ((number? d)
141		   (display-char #\# port)
142		   (writer d port)
143		   (display-char #\# port))
144		  (else
145		   (display-char #\# port)
146		   (writer label port)
147		   (display-char #\= port)
148		   (assign-label! p)
149		   (write-interesting/shared o))))))
150
151    (write/shared obj))
152
153  (define (display o #!optional (p ##sys#standard-output))
154    (write-with-shared-structure
155     display-simple
156     o
157     #t
158     p))
159
160  (define (write o  #!optional (p ##sys#standard-output))
161    (write-with-shared-structure
162     write-simple
163     o
164     #t
165     p))
166
167  (define (write-shared o #!optional (p ##sys#standard-output))
168    (write-with-shared-structure
169     write-simple
170     o
171     #f
172     p))
173
174)
175
176(module scheme.time (current-second
177		     current-jiffy
178		     jiffies-per-second)
179  (import (only chicken.base define-constant)
180          (chicken foreign)
181	  (only chicken.time current-seconds)
182	  (only scheme + define inexact->exact))
183
184  ;; As of 2012-06-30.
185  (define-constant tai-offset 35.)
186
187  (define (current-second) (+ (current-seconds) tai-offset))
188
189  (define current-jiffy (foreign-lambda integer "clock"))
190
191  (define (jiffies-per-second) (foreign-value "CLOCKS_PER_SEC" integer))
192
193)
194
195(module scheme.file (file-exists? delete-file
196                     open-input-file open-binary-input-file
197                     open-output-file open-binary-output-file
198                     call-with-input-file call-with-output-file
199                     with-input-from-file with-output-to-file)
200  (import (only scheme and define quote let apply open-input-file open-output-file call-with-input-file
201                call-with-output-file with-input-from-file with-output-to-file)
202          (rename (only (chicken file) delete-file file-exists?) (file-exists? file-exists?/base)))
203
204  (define (open-binary-input-file fname . args)
205    (let ((p (apply open-input-file fname #:binary args)))
206      (##sys#setslot p 14 'binary)
207      p))
208
209  (define (open-binary-output-file fname . args)
210    (let ((p (apply open-output-file fname #:binary args)))
211      (##sys#setslot p 14 'binary)
212      p))
213
214  (define (file-exists? fname)
215    (and (file-exists?/base fname) #t))
216
217)
218
219(module scheme.process-context (command-line
220				emergency-exit
221				exit
222				get-environment-variable
223				get-environment-variables)
224  (import scheme
225          chicken.process-context
226          chicken.type
227	  (rename chicken.base (exit chicken-exit)))
228
229(define (command-line)
230  ;; Don't cache these; they may be parameterized at any time!
231  (cons (program-name) (command-line-arguments)))
232
233(define (->exit-status obj)
234  (cond ((integer? obj) obj)
235        ((eq? obj #f) 1)
236        (else 0)))
237
238(define (exit #!optional (obj 0))
239  ;; ##sys#dynamic-unwind is hidden, have to unwind manually.
240  ; (##sys#dynamic-unwind '() (length ##sys#dynamic-winds))
241  (let unwind ()
242    (unless (null? ##sys#dynamic-winds)
243      (let ((after (cdar ##sys#dynamic-winds)))
244        (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
245        (after)
246        (unwind))))
247  ;; The built-in exit runs cleanup handlers for us.
248  (chicken-exit (->exit-status obj)))
249
250)
251