env.scm

   1 ;;;; File: "env.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
   4 ;;;; All Rights Reserved.
   5
   6 ;; Environment representation.
   7
   8 (define-type var
   9   id
  10   global?
  11   (refs unprintable:)
  12   (sets unprintable:)
  13   (defs unprintable:)
  14   needed?
  15   primitive
  16 )
  17
  18 (define-type primitive
  19   nargs
  20   inliner
  21   unspecified-result?
  22 )
  23
  24 (define-type renaming
  25   renamings
  26 )
  27
  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 '#%* #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 '#%> #t '() '() '() #f (make-primitive 2 #f #f))
  42      (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f))
  43      (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
  44      (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
  45      (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
  46      (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
  47      (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
  48      (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
  49      (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
  50      (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
  51      (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
  52      (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
  53      (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
  54      (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
  55      (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
  56      (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
  57      (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
  58      (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
  59      (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))
  60      (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
  61      (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f))
  62      (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t))
  63      (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
  64      (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
  65      (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
  66      (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
  67      (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
  68      (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
  69      (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
  70      (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
  71      (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
  72      (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f))
  73      (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
  74      (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f))
  75      (make-var '#%u8vector-copy! #t '() '() '() #f (make-primitive 5 #f #t))
  76      (make-var '#%boolean? #t '() '() '() #f (make-primitive 1 #f #f))
  77      (make-var '#%network-init #t '() '() '() #f (make-primitive 0 #f #t))
  78      (make-var '#%network-cleanup #t '() '() '() #f (make-primitive 0 #f #t))
  79      (make-var '#%receive-packet-to-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
  80      (make-var '#%send-packet-from-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
  81      (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f))
  82      (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f))
  83
  84      (make-var '#%readyq #t '() '() '() #f #f)
  85      ;; TODO put in a meaningful order
  86      )))
  87
  88 ;; list of primitives that can be safely substituted for the equivalent
  89 ;; function when it is called.
  90 ;; this saves the calls to the primitive wrapper functions, which are still
  91 ;; needed if a program needs the value of a "primitive", for example in :
  92 ;; (define foo car)
  93 (define substitute-primitives
  94   '((number? . #%number?)
  95     (quotient . #%quotient)
  96     (remainder . #%remainder)
  97     (= . #%=)
  98     (< . #%<)
  99     (> . #%>)
 100     (<= . #%<=)
 101     (>= . #%>=)
 102     (pair? . #%pair?)
 103     (cons . #%cons)
 104     (car . #%car)
 105     (cdr . #%cdr)
 106     (set-car! . #%set-car!)
 107     (set-cdr! . #%set-cdr!)
 108     (null? . #%null?)
 109     (eq? . #%eq?)
 110     (not . #%not)
 111     (modulo . #%remainder)
 112     (symbol? . #%symbol?)
 113     (string? . #%string?)
 114     (string->list . #%string->list)
 115     (list->string . #%list->string)
 116     (clock . #%clock)
 117     (beep . #%beep)
 118     (light . #%adc)
 119     (adc . #%adc)
 120     (sernum . #%sernum)
 121     (motor . #%motor)
 122     (led . #%led)
 123     (bitwise-ior . #%ior)
 124     (bitwise-xor . #%xor)
 125     (current-time . #%clock)
 126     (u8vector-length . #%u8vector-length)
 127     (u8vector-ref . #%u8vector-ref)
 128     (u8vector-set! . #%u8vector-set!)
 129     (make-u8vector . #%make-u8vector)
 130     (u8vector-copy! . #%u8vector-copy!)
 131     (boolean? . #%boolean?)
 132     (network-init . #%network-init)
 133     (network-cleanup . #%network-cleanup)
 134     (receive-packet-to-u8vector . #%receive-packet-to-u8vector)
 135     (send-packet-from-u8vector . #%send-packet-from-u8vector)
 136     ))
 137
 138 (define env-lookup
 139   (lambda (env id)
 140     (let loop ((lst env) (id id))
 141       (let ((b (car lst)))
 142         (cond ((and (renaming? b)
 143                     (assq id (renaming-renamings b)))
 144                =>
 145                (lambda (x)
 146                  (loop (cdr lst) (cadr x))))
 147               ((and (var? b)
 148                     (eq? (var-id b) id))
 149                b)
 150               ((null? (cdr lst))
 151                (let ((x (make-var id #t '() '() '() #f #f)))
 152                  (set-cdr! lst (cons x '()))
 153                  x))
 154               (else
 155                (loop (cdr lst) id)))))))
 156
 157 (define env-extend
 158   (lambda (env ids def)
 159     (append (map (lambda (id)
 160                    (make-var id #f '() '() (list def) #f #f))
 161                  ids)
 162             env)))
 163
 164 (define env-extend-renamings
 165   (lambda (env renamings)
 166     (cons (make-renaming renamings) env)))
 167
 168 (define *macros* '())