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 '#%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))
  80
  81      (make-var '#%readyq #t '() '() '() #f #f)
  82      ;; TODO put in a meaningful order
  83      )))
  84
  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 :
  89 ;; (define foo car)
  90 (define substitute-primitives
  91   '((number? . #%number?)
  92     (quotient . #%quotient)
  93     (remainder . #%remainder)
  94     (= . #%=)
  95     (< . #%<)
  96     (> . #%>)
  97     (pair? . #%pair?)
  98     (cons . #%cons)
  99     (car . #%car)
 100     (cdr . #%cdr)
 101     (set-car! . #%set-car!)
 102     (set-cdr! . #%set-cdr!)
 103     (null? . #%null?)
 104     (eq? . #%eq?)
 105     (not . #%not)
 106     (modulo . #%remainder)
 107     (symbol? . #%symbol?)
 108     (string? . #%string?)
 109     (string->list . #%string->list)
 110     (list->string . #%list->string)
 111     (clock . #%clock)
 112     (beep . #%beep)
 113     (light . #%adc)
 114     (adc . #%adc)
 115     (sernum . #%sernum)
 116     (motor . #%motor)
 117     (led . #%led)
 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)
 129     ))
 130
 131 (define env-lookup
 132   (lambda (env id)
 133     (let loop ((lst env) (id id))
 134       (let ((b (car lst)))
 135         (cond ((and (renaming? b)
 136                     (assq id (renaming-renamings b)))
 137                =>
 138                (lambda (x)
 139                  (loop (cdr lst) (cadr x))))
 140               ((and (var? b)
 141                     (eq? (var-id b) id))
 142                b)
 143               ((null? (cdr lst))
 144                (let ((x (make-var id #t '() '() '() #f #f)))
 145                  (set-cdr! lst (cons x '()))
 146                  x))
 147               (else
 148                (loop (cdr lst) id)))))))
 149
 150 (define env-extend
 151   (lambda (env ids def)
 152     (append (map (lambda (id)
 153                    (make-var id #f '() '() (list def) #f #f))
 154                  ids)
 155             env)))
 156
 157 (define env-extend-renamings
 158   (lambda (env renamings)
 159     (cons (make-renaming renamings) env)))
 160
 161 (define *macros* '())