~ chicken-core (chicken-5) /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
 61(include "common-declarations.scm")
 62(include "mini-srfi-1.scm")
 63
 64
 65;;; Convert string into valid C-identifier:
 66
 67(define (string->c-identifier str)
 68  (let ((out (open-output-string))
 69	(n (string-length str)))
 70    (do ((i 0 (fx+ i 1)))
 71	((fx>= i n) (get-output-string out))
 72      (let ((c (string-ref str i)))
 73	(if (and (not (char-alphabetic? c))
 74		 (or (not (char-numeric? c)) (fx= i 0)))
 75	    (let ((i (char->integer c)))
 76	      (write-char #\_ out)
 77	      (when (fx< i 16) (write-char #\0 out))
 78	      (display (number->string i 16) out))
 79	    (write-char c out))))))
 80
 81
 82;;; Parse library specifications:
 83
 84(define (valid-library-specifier? x)
 85  (or (symbol? x)
 86      (and (list? x)
 87	   (not (null? x))
 88	   (every (lambda (x) (or (symbol? x) (fixnum? x))) x))))
 89
 90(define (library-id lib)
 91  (define (fail)
 92    (##sys#error "invalid library specifier" lib))
 93  (define (srfi? x)
 94    (and (pair? (cdr x))
 95	 (null? (cddr x))
 96	 (eq? 'srfi (car x))
 97	 (fixnum? (cadr x))))
 98  (define (library-part->string x)
 99    (cond ((symbol? x) (##sys#symbol->string x))
100	  ((fixnum? x) (##sys#number->string x))
101	  (else (fail))))
102  (cond
103    ((symbol? lib) lib)
104    ((null? lib) (fail))
105    ((not (list? lib)) (fail))
106    ((srfi? lib)
107     (##sys#intern-symbol
108      (##sys#string-append "srfi-" (##sys#number->string (cadr lib)))))
109    (else
110     (do ((lst (cdr lib) (cdr lst))
111	  (str (library-part->string (car lib))
112	       (string-append str "." (library-part->string (car lst)))))
113	 ((null? lst)
114	  (##sys#intern-symbol str))))))
115
116
117;;; Requirement identifier for modules:
118
119(define (module-requirement id)
120  (##sys#string->symbol
121   (##sys#string-append (##sys#slot id 1) "#")))
122
123
124;;; Check for multiple bindings in "let"-style constructs:
125
126(define (check-for-multiple-bindings bindings form loc)
127  ;; assumes correct syntax
128  (let loop ((bs bindings) (seen '()) (warned '()))
129    (cond ((null? bs))
130	  ((and (memq (caar bs) seen)
131                (not (memq (caar bs) warned)))
132	   (##sys#warn
133	    (string-append "variable bound multiple times in " loc " construct")
134	    (caar bs)
135	    form)
136	   (loop (cdr bs) seen (cons (caar bs) warned)))
137	  (else (loop (cdr bs) (cons (caar bs) seen) warned)))))
138
139
140;;; Macro environment manipulation:
141(define (macro-subset me0 #!optional parent-env)
142  (let ((se (let loop ((me (##sys#macro-environment)))
143	      (if (or (null? me) (eq? me me0))
144		  '()
145		  (cons (car me) (loop (cdr me)))))))
146    (fixup-macro-environment se parent-env)))
147
148(define (fixup-macro-environment se #!optional parent-env)
149  (let ((se2 (if parent-env (##sys#append se parent-env) se)))
150    (for-each				; fixup se
151     (lambda (sdef)
152       (when (pair? (cdr sdef))
153	 (set-car!
154	  (cdr sdef)
155	  (if (null? (cadr sdef))
156	      se2
157	      (##sys#append (cadr sdef) se2)))))
158     se)
159    se))
160
161
162;;; Low-level hashtable support:
163
164(define hash-symbol
165  (let ((cache-s #f)
166	(cache-h #f)
167	;; NOTE: All low-level hash tables share the same randomization factor
168	(rand (##core#inline "C_rand" #x10000)))
169    (lambda (s n)
170      (if (eq? s cache-s)
171	  (##core#inline "C_fixnum_modulo" cache-h n)
172	  (begin
173	    (set! cache-s s)
174	    (set! cache-h (##core#inline "C_u_i_string_hash" (##sys#slot s 1) rand))
175	    (##core#inline "C_fixnum_modulo" cache-h n))))))
176
177(define (make-hash-table #!optional (size 301))
178  (make-vector size '()))
179
180(define (hash-table-ref ht key)
181  (let loop ((bucket (##sys#slot ht (hash-symbol key (##core#inline "C_block_size" ht)))))
182    (and (not (eq? '() bucket))
183	 (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
184	     (##sys#slot (##sys#slot bucket 0) 1)
185	     (loop (##sys#slot bucket 1))))))
186
187(define (hash-table-set! ht key val)
188  (let* ((k (hash-symbol key (##core#inline "C_block_size" ht)))
189	 (ib (##sys#slot ht k)))
190      (let loop ((bucket ib))
191	(if (eq? '() bucket)
192	    (##sys#setslot ht k (cons (cons key val) ib))
193	    (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
194		(##sys#setslot (##sys#slot bucket 0) 1 val)
195		(loop (##sys#slot bucket 1)))))))
196
197(define (hash-table-update! ht key updtfunc valufunc)
198  (hash-table-set! ht key (updtfunc (or (hash-table-ref ht key) (valufunc)))))
199
200(define (hash-table-for-each p ht)
201  (let ((len (##core#inline "C_block_size" ht)))
202    (do ((i 0 (fx+ i 1)))
203	((fx>= i len))
204      (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1)))
205		      (##sys#slot ht i)))))
206
207(define (hash-table-size ht)
208  (let loop ((len (##sys#size ht)) (bkt 0) (size 0))
209    (if (fx= bkt len)
210	size
211	(loop len (fx+ bkt 1) (fx+ size (##sys#length (##sys#slot ht bkt)))))))
212
213;;; Modules that are made available to code by default:
214
215;; WARNING: These import libs must all exist.  They cannot be emitted,
216;; because the compiler itself needs them to expand macros!
217;; WARNING: These also need to be built into modules.scm, so that
218;; statically linked programs can eval the imports for these modules.
219
220(define default-imports '(scheme chicken.base chicken.syntax))
221(define default-syntax-imports '(scheme chicken.base chicken.syntax))
222
223) ; chicken.internal