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 '#%= #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      )))
  83
  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     ))
 128
 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)))))))
 147
 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)))
 154
 155 (define env-extend-renamings
 156   (lambda (env renamings)
 157     (cons (make-renaming renamings) env)))
 158
 159 (define *macros* '())