Removed code that dealt with ROM closure, since these don't exist.
[picobit.git] / env.scm
blobe05c56f402470f2b2db0fd3ffef262689ef3b13b
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.
8 (define-type var
9   id
10   global?
11   (refs unprintable:) 
12   (sets unprintable:)
13   (defs unprintable:)
14   needed?
15   primitive
18 (define-type primitive
19   nargs
20   inliner
21   unspecified-result?
24 (define-type renaming
25   renamings
28 (define make-global-env
29   (lambda ()
30     (list
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 '#%mul-non-neg #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 '#%= #t '() '() '() #f (make-primitive 2 #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 '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
41      (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
42      (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
43      (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
44      (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
45      (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
46      (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
47      (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
48      (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
49      (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
50      (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
51      (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
52      (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
53      (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
54      (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
55      (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
56      (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))     
57      (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
58      (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f))
59      (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t))
60      (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
61      (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
62      (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
63      (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
64      (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
65      (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
66      (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
67      (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
68      (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
69      (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f))
70      (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
71      (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f))
72      (make-var '#%boolean? #t '() '() '() #f (make-primitive 1 #f #f))
73      (make-var '#%network-init #t '() '() '() #f (make-primitive 0 #f #t))
74      (make-var '#%network-cleanup #t '() '() '() #f (make-primitive 0 #f #t))
75      (make-var '#%receive-packet-to-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
76      (make-var '#%send-packet-from-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
77      (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f))
78      (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f))
79      
80      (make-var '#%readyq #t '() '() '() #f #f)
81      ;; TODO put in a meaningful order
82      )))
84 ;; list of primitives that can be safely substituted for the equivalent
85 ;; function when it is called.
86 ;; this saves the calls to the primitive wrapper functions, which are still
87 ;; needed if a program needs the value of a "primitive", for example in :
88 ;; (define foo car)
89 (define substitute-primitives
90   '((number? . #%number?)
91     (remainder . #%remainder)
92     (= . #%=)
93     (< . #%<)
94     (> . #%>)
95     (pair? . #%pair?)
96     (cons . #%cons)
97     (car . #%car)
98     (cdr . #%cdr)
99     (set-car! . #%set-car!)
100     (set-cdr! . #%set-cdr!)
101     (null? . #%null?)
102     (eq? . #%eq?)
103     (not . #%not)
104     (modulo . #%remainder)
105     (symbol? . #%symbol?)
106     (string? . #%string?)
107     (string->list . #%string->list)
108     (list->string . #%list->string)
109     (clock . #%clock)
110     (beep . #%beep)
111     (light . #%adc)
112     (adc . #%adc)
113     (sernum . #%sernum)
114     (motor . #%motor)
115     (led . #%led)
116     (bitwise-ior . #%ior)
117     (bitwise-xor . #%xor)
118     (current-time . #%clock)
119     (u8vector-length . #%u8vector-length)
120     (u8vector-ref . #%u8vector-ref)
121     (u8vector-set! . #%u8vector-set!)
122     (boolean? . #%boolean?)
123     (network-init . #%network-init)
124     (network-cleanup . #%network-cleanup)
125     (receive-packet-to-u8vector . #%receive-packet-to-u8vector)
126     (send-packet-from-u8vector . #%send-packet-from-u8vector)
127     ))
129 (define env-lookup
130   (lambda (env id)
131     (let loop ((lst env) (id id))
132       (let ((b (car lst)))
133         (cond ((and (renaming? b)
134                     (assq id (renaming-renamings b)))
135                =>
136                (lambda (x)
137                  (loop (cdr lst) (cadr x))))
138               ((and (var? b)
139                     (eq? (var-id b) id))
140                b)
141               ((null? (cdr lst))
142                (let ((x (make-var id #t '() '() '() #f #f)))
143                  (set-cdr! lst (cons x '()))
144                  x))
145               (else
146                (loop (cdr lst) id)))))))
148 (define env-extend
149   (lambda (env ids def)
150     (append (map (lambda (id)
151                    (make-var id #f '() '() (list def) #f #f))
152                  ids)
153             env)))
155 (define env-extend-renamings
156   (lambda (env renamings)
157     (cons (make-renaming renamings) env)))
159 (define *macros* '())