~ chicken-core (master) /internal.scm

  1;;;; internal.scm - Runtime support module for CHICKEN
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer.
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution.
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission.
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27(declare
 28  (unit internal)
 29  (disable-interrupts)
 30  (fixnum))
 31
 32;; This is a bit of a grab-bag of stuff that's used in various places
 33;; in the runtime and the compiler, but which is not supposed to be
 34;; used by the user, and doesn't strictly belong anywhere in
 35;; particular.
 36(module chicken.internal
 37   (;; Convert string into valid C-identifier
 38    string->c-identifier
 39
 40    ;; Parse library specifications
 41    library-id valid-library-specifier?
 42
 43    ;; Requirement identifier for modules
 44    module-requirement
 45
 46    ;;; Check for multiple bindings in "let"-style constructs
 47    check-for-multiple-bindings
 48
 49    ;;; Macro environment manipulation
 50    macro-subset fixup-macro-environment
 51
 52    ;; Low-level hash table support
 53    make-hash-table hash-table-ref hash-table-set! hash-table-update!
 54    hash-table-for-each hash-table-size
 55
 56    ;; Modules that are made available to code by default
 57    default-imports default-syntax-imports)
 58
 59(import scheme chicken.base chicken.fixnum)
 60(import (only (scheme base) open-output-string get-output-string))
 61
 62(include "common-declarations.scm")
 63(include "mini-srfi-1.scm")
 64
 65
 66;;; Convert string into valid C-identifier:
 67
 68(define (string->c-identifier str)
 69  (let ((out (open-output-string))
 70	(n (string-length str)))
 71    (do ((i 0 (fx+ i 1)))
 72	((fx>= i n) (get-output-string out))
 73      (let ((c (string-ref str i)))
 74	(if (and (not (char-alphabetic? c))
 75		 (or (not (char-numeric? c)) (fx= i 0)))
 76	    (let ((i (char->integer c)))
 77	      (write-char #\_ out)
 78	      (when (fx< i 16) (write-char #\0 out))
 79	      (display (number->string i 16) out))
 80	    (write-char c out))))))
 81
 82
 83;;; Parse library specifications:
 84
 85(define (valid-library-specifier? x)
 86  (or (symbol? x)
 87      (and (list? x)
 88	   (not (null? x))
 89	   (every (lambda (x) (or (symbol? x) (fixnum? x))) x))))
 90
 91(define (library-id lib)
 92  (define (fail)
 93    (##sys#error "invalid library specifier" lib))
 94  (define (srfi? x)
 95    (and (pair? (cdr x))
 96	 (null? (cddr x))
 97	 (eq? 'srfi (car x))
 98	 (fixnum? (cadr x))))
 99  (define (library-part->string x)
100    (cond ((symbol? x) (##sys#symbol->string/shared x))
101	  ((fixnum? x) (##sys#number->string x))
102	  (else (fail))))
103  (cond
104    ((symbol? lib) lib)
105    ((null? lib) (fail))
106    ((not (list? lib)) (fail))
107    ((srfi? lib)
108     (##sys#string->symbol
109      (##sys#string-append "srfi-" (##sys#number->string (cadr lib)))))
110    (else
111     (do ((lst (cdr lib) (cdr lst))
112	  (str (library-part->string (car lib))
113	       (string-append str "." (library-part->string (car lst)))))
114	 ((null? lst)
115	  (##sys#string->symbol str))))))
116
117
118;;; Requirement identifier for modules:
119
120(define (module-requirement id)
121  (##sys#string->symbol
122   (##sys#string-append (##sys#symbol->string/shared id) "#")))
123
124
125;;; Check for multiple bindings in "let"-style constructs:
126
127(define (check-for-multiple-bindings bindings form loc)
128  ;; assumes correct syntax
129  (let loop ((bs bindings) (seen '()) (warned '()))
130    (cond ((null? bs))
131	  ((and (memq (caar bs) seen)
132                (not (memq (caar bs) warned)))
133	   (##sys#warn
134	    (string-append "variable bound multiple times in " loc " construct")
135	    (caar bs)
136	    form)
137	   (loop (cdr bs) seen (cons (caar bs) warned)))
138	  (else (loop (cdr bs) (cons (caar bs) seen) warned)))))
139
140
141;;; Macro environment manipulation:
142(define (macro-subset me0 #!optional parent-env)
143  (let ((se (let loop ((me (##sys#macro-environment)))
144	      (if (or (null? me) (eq? me me0))
145		  '()
146		  (cons (car me) (loop (cdr me)))))))
147    (fixup-macro-environment se parent-env)))
148
149;;XXX clarify what this does!
150(define (fixup-macro-environment se #!optional parent-env)
151  (let ((se2 (if parent-env (##sys#append se parent-env) se)))
152    (for-each				; fixup se
153     (lambda (sdef)
154       (when (pair? (cdr sdef))
155	 (set-car!
156	  (cdr sdef)
157	  (if (null? (cadr sdef))
158	      se2
159	      (##sys#append (cadr sdef) se2)))))
160     se)
161    se))
162
163
164;;; Low-level hashtable support:
165
166(define hash-symbol
167  (let ((cache-s #f)
168	(cache-h #f)
169	;; NOTE: All low-level hash tables share the same randomization factor
170	(rand (##core#inline "C_rand" #x10000)))
171    (lambda (s n)
172      (if (eq? s cache-s)
173	  (##core#inline "C_fixnum_modulo" cache-h n)
174	  (let ((bv (##sys#slot s 1)))
175	    (set! cache-s s)
176	    (set! cache-h (##core#inline "C_u_i_bytevector_hash" bv 0 (fx- (##sys#size bv) 1) rand))
177	    (##core#inline "C_fixnum_modulo" cache-h n))))))
178
179(define (make-hash-table #!optional (size 301))
180  (make-vector size '()))
181
182(define (hash-table-ref ht key)
183  (let loop ((bucket (##sys#slot ht (hash-symbol key (##sys#size ht)))))
184    (and (not (eq? '() bucket))
185	 (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
186	     (##sys#slot (##sys#slot bucket 0) 1)
187	     (loop (##sys#slot bucket 1))))))
188
189(define (hash-table-set! ht key val)
190  (let* ((k (hash-symbol key (##sys#size ht)))
191	 (ib (##sys#slot ht k)))
192      (let loop ((bucket ib))
193	(if (eq? '() bucket)
194	    (##sys#setslot ht k (cons (cons key val) ib))
195	    (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
196		(##sys#setslot (##sys#slot bucket 0) 1 val)
197		(loop (##sys#slot bucket 1)))))))
198
199(define (hash-table-update! ht key updtfunc valufunc)
200  (hash-table-set! ht key (updtfunc (or (hash-table-ref ht key) (valufunc)))))
201
202(define (hash-table-for-each p ht)
203  (let ((len (##core#inline "C_block_size" ht)))
204    (do ((i 0 (fx+ i 1)))
205	((fx>= i len))
206      (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1)))
207		      (##sys#slot ht i)))))
208
209(define (hash-table-size ht)
210  (let loop ((len (##sys#size ht)) (bkt 0) (size 0))
211    (if (fx= bkt len)
212	size
213	(loop len (fx+ bkt 1) (fx+ size (##sys#length (##sys#slot ht bkt)))))))
214
215;;; Modules that are made available to code by default:
216
217;; WARNING: These import libs must all exist.  They cannot be emitted,
218;; because the compiler itself needs them to expand macros!
219;; WARNING: These also need to be built into modules.scm, so that
220;; statically linked programs can eval the imports for these modules.
221
222(define default-imports '(scheme chicken.base chicken.syntax))
223(define default-syntax-imports '(scheme chicken.base chicken.syntax))
224
225) ; chicken.internal