1 ;;;; File: "env.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
4 ;;;; All Rights Reserved.
6 ;; Environment representation.
18 (define-type primitive
28 (define make-global-env
31 (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f))
32 (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f))
33 (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f))
34 (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f))
35 (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
36 (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
37 (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
38 (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
39 (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
40 (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
41 (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
42 (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
43 (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
44 (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
45 (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
46 (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
47 (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
48 (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
49 (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
50 (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
51 (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
52 (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
53 (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
54 (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
55 (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
56 (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
57 (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))
58 (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
59 (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f))
60 (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t))
61 (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
62 (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
63 (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
64 (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
65 (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
66 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
67 (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
68 (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
69 (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
70 (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f))
71 (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
72 (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f))
73 (make-var '#%boolean? #t '() '() '() #f (make-primitive 1 #f #f))
74 (make-var '#%network-init #t '() '() '() #f (make-primitive 0 #f #t))
75 (make-var '#%network-cleanup #t '() '() '() #f (make-primitive 0 #f #t))
76 (make-var '#%receive-packet-to-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
77 (make-var '#%send-packet-from-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
78 (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f))
79 (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f))
81 (make-var '#%readyq #t '() '() '() #f #f)
82 ;; TODO put in a meaningful order
85 ;; list of primitives that can be safely substituted for the equivalent
86 ;; function when it is called.
87 ;; this saves the calls to the primitive wrapper functions, which are still
88 ;; needed if a program needs the value of a "primitive", for example in :
90 (define substitute-primitives
91 '((number? . #%number?)
92 (quotient . #%quotient)
93 (remainder . #%remainder)
101 (set-car! . #%set-car!)
102 (set-cdr! . #%set-cdr!)
106 (modulo . #%remainder)
107 (symbol? . #%symbol?)
108 (string? . #%string?)
109 (string->list . #%string->list)
110 (list->string . #%list->string)
118 (bitwise-ior . #%ior)
119 (bitwise-xor . #%xor)
120 (current-time . #%clock)
121 (u8vector-length . #%u8vector-length)
122 (u8vector-ref . #%u8vector-ref)
123 (u8vector-set! . #%u8vector-set!)
124 (boolean? . #%boolean?)
125 (network-init . #%network-init)
126 (network-cleanup . #%network-cleanup)
127 (receive-packet-to-u8vector . #%receive-packet-to-u8vector)
128 (send-packet-from-u8vector . #%send-packet-from-u8vector)
133 (let loop ((lst env) (id id))
135 (cond ((and (renaming? b)
136 (assq id (renaming-renamings b)))
139 (loop (cdr lst) (cadr x))))
144 (let ((x (make-var id #t '() '() '() #f #f)))
145 (set-cdr! lst (cons x '()))
148 (loop (cdr lst) id)))))))
151 (lambda (env ids def)
152 (append (map (lambda (id)
153 (make-var id #f '() '() (list def) #f #f))
157 (define env-extend-renamings
158 (lambda (env renamings)
159 (cons (make-renaming renamings) env)))
161 (define *macros* '())