home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d556 / scheme2c.lha / Scheme2C / Scheme-src.lzh / scsc / miscexp.sc < prev    next >
Text File  |  1991-10-11  |  10KB  |  283 lines
  1. ;;; The functions in this file expand those special forms which don't require
  2. ;;; gobs of code.  The global variables that are visible outside this module
  3. ;;; include:
  4. ;;;
  5.  
  6. ;*              Copyright 1989 Digital Equipment Corporation
  7. ;*                         All Rights Reserved
  8. ;*
  9. ;* Permission to use, copy, and modify this software and its documentation is
  10. ;* hereby granted only under the following terms and conditions.  Both the
  11. ;* above copyright notice and this permission notice must appear in all copies
  12. ;* of the software, derivative works or modified versions, and any portions
  13. ;* thereof, and both notices must appear in supporting documentation.
  14. ;*
  15. ;* Users of this software agree to the terms and conditions set forth herein,
  16. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  17. ;* right and license under any changes, enhancements or extensions made to the
  18. ;* core functions of the software, including but not limited to those affording
  19. ;* compatibility with other hardware or software environments, but excluding
  20. ;* applications which incorporate this software.  Users further agree to use
  21. ;* their best efforts to return to Digital any such changes, enhancements or
  22. ;* extensions that they make and inform Digital of noteworthy uses of this
  23. ;* software.  Correspondence should be provided to Digital at:
  24. ;* 
  25. ;*                       Director of Licensing
  26. ;*                       Western Research Laboratory
  27. ;*                       Digital Equipment Corporation
  28. ;*                       100 Hamilton Avenue
  29. ;*                       Palo Alto, California  94301  
  30. ;* 
  31. ;* This software may be distributed (but not offered for sale or transferred
  32. ;* for compensation) to third parties, provided such third parties agree to
  33. ;* abide by the terms and conditions of this notice.  
  34. ;* 
  35. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  36. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  37. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  38. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  39. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  40. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  41. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  42. ;* SOFTWARE.
  43.  
  44. (module miscexp)
  45.  
  46. ;;; External and in-line definitions.
  47.  
  48. (include "plist.sch")
  49. (include "miscexp.sch")
  50.  
  51. (define QUOTE-CONSTANTS '())    ; A-list for constants.
  52.  
  53. ;;; (f a b c)  ==>  ($call tail-call f' a' b' c')
  54. ;;;
  55. ;;; Expands a function call, where x' denotes x expanded by exp-func.  The
  56. ;;; tail-call flag is set later on calls that could be tail recursive.
  57. ;;; Functions with are lambda expressions with optional arguments require
  58. ;;; special processing.  This is done so TRANSFORM will only have to transform
  59. ;;; calls to lambda expressions with a fixed number of elements.  Lambda
  60. ;;; variables which are bound to functions are also noted here.
  61.  
  62. (define (CALL-EXP exp exp-func)
  63.     (let* ((call  (exp-func (car exp) exp-func))
  64.        (id    (if ($lambda? call) ($lambda-id call) #f)))
  65.       (cond (id
  66.            (do ((vals (cdr exp) (cdr vals))
  67.             (vars (lambda-reqvars id) (cdr vars))
  68.             (opt  (lambda-optvars id))
  69.             (newvars '())
  70.             (newvals '())
  71.             (const-bnd '()))
  72.                ((or (null? vars) (not (pair? vals)))
  73.             (if const-bnd
  74.                 (letrec-lambdas const-bnd ($lambda-body call)))
  75.             (cond ((and (null? opt) (null? vals) (null? vars))
  76.                    `($call () ,call ,@(reverse newvals)))
  77.                   ((and opt (islist vals 0))
  78.                    (set-lambda-reqvars! id
  79.                    (reverse (cons (car opt) newvars)))
  80.                    (set-lambda-optvars! id '())
  81.                    `($call () ,call
  82.                        ,@(reverse newvals)
  83.                        ,(exp-form (call-exp-cons vals)
  84.                         exp-func)))
  85.                   (else (expand-error 'call exp))))
  86.                (let ((var (car vars))
  87.                  (val (exp-func (car vals) exp-func)))
  88.                 (set! newvars (cons var newvars))
  89.                 (set! newvals (cons val newvals))
  90.                 (if (and (symbol? val)
  91.                      (eq? (id-use val) 'constant))
  92.                 (set! const-bnd (cons var const-bnd)))
  93.                 (if (and ($lambda? val) (not (id-set! var)))
  94.                 (name-a-lambda var val)))))
  95.         (else
  96.              (set! exp (cons call (exp-form-list (cdr exp) exp-func)))
  97.              `($call () ,@exp)))))
  98.  
  99. (define (LETREC-LAMBDAS vars exps)
  100.     (if (pair? exps)
  101.     (let ((var ($set-id (car exps)))
  102.           (val ($set-exp (car exps))))
  103.          (if (memq var vars)
  104.          (begin (if (and ($lambda? val) (eq? (id-set! var) 1))
  105.                 (name-a-lambda var val))
  106.             (letrec-lambdas vars (cdr exps)))))))
  107.  
  108. (define (CALL-EXP-CONS vals)
  109.     (cond (vals `(cons ,(car vals) ,(call-exp-cons (cdr vals))))
  110.       (else ''())))
  111.  
  112. (define ($CALL? x) ($call? x))
  113.  
  114. (define ($CALL-TAIL x) ($call-tail x))
  115.  
  116. (define (SET-$CALL-TAIL! x v) (set-$call-tail! x v))
  117.  
  118. (define ($CALL-FUNC x) ($call-func x))
  119.  
  120. (define (SET-$CALL-FUNC! x f) (set-$call-func! x f))
  121.  
  122. (define ($CALL-ARGL x) ($call-argl x))
  123.  
  124. (define (SET-$CALL-ARGL! x al) (SET-$CALL-ARGL! x al))
  125.  
  126. ;;; The special form LAP allows the definition of "inline" C code.  An inline
  127. ;;; function is called by:
  128. ;;;
  129. ;;;    ((lap (vars ... ) <lap code> ...) args ...)
  130. ;;;
  131. ;;; The arguments will be evaluated and then the values are substituted for
  132. ;;; the variables in the lap code.  The form returns a tagged scheme pointer
  133. ;;; as its value.
  134. ;;;
  135. ;;; Unless the <lap code> contains the macro SET, then it is assumed that the
  136. ;;; code does not change any cells.  The macro BOOLEAN converts a C boolean
  137. ;;; into a Scheme boolean.  When it is the outermost form, it allows some
  138. ;;; optimizing transforms.
  139.  
  140. (define (LAP-EXP exp exp-func)
  141.     (if (and (islist exp 3) (islist (cadr exp) 0))
  142.     (let* ((vars (cadr exp))
  143.            (body (cddr exp))
  144.            (set  (let loop ((exp body))
  145.               (cond ((and (pair? exp) (eq? (car exp) 'set))
  146.                  #t)
  147.                 ((pair? exp)
  148.                  (or (loop (car exp)) (loop (cdr exp))))
  149.                 (else #f)))))
  150.           `($lap ,(cond (set 'set)
  151.                 ((and (= (length body) 1)
  152.                   (pair? (car body))
  153.                   (eq? (caar body) 'boolean))
  154.                  'boolean)
  155.                 (else 'read-only))
  156.              ,vars
  157.              ,@body))
  158.     (expand-error (car exp) exp)))
  159.  
  160. (define ($LAP? x) ($lap? x))
  161.  
  162. (define ($LAP-TYPE x) ($lap-type x))
  163.  
  164. (define ($LAP-VARS x) ($lap-vars x))
  165.  
  166. (define ($LAP-BODY x) ($lap-body x))
  167.  
  168. (define (SET-$LAP-BODY! exp body) (set-$lap-body! exp body))
  169.  
  170. ;;; (quote x)  ==>  const_<id>
  171. ;;;
  172. ;;; Quoted objects become constant variables.  Multiple occurences of the same
  173. ;;; object will share the same variable.  Note that some constants are
  174. ;;; globally defined so they get turned into a reference to that external
  175. ;;; variable.
  176.  
  177. (define (QUOTE-EXP exp exp-func)
  178.     (if (islist exp 2 2)
  179.     (let* ((const (cadr exp))
  180.            (const-var (assoc const quote-constants)))
  181.           (cond ((and const-var (eq? (id-use (cadr const-var)) 'constant))
  182.              (cadr const-var)) 
  183.             ((eq? const '#t) true-alpha)
  184.             ((eq? const '()) empty-list-alpha)
  185.             ((eq? const '#f) false-alpha)
  186.             ((equal? const "") (bound '$_empty-string))
  187.             ((equal? const '#()) (bound '$_empty-vector))
  188.             (else
  189.              (let ((var (newv 'c 'use 'constant 'value const)))
  190.                   (set! quote-constants
  191.                     (cons (list const var) quote-constants))
  192.                   var))))
  193.     (expand-error 'quote exp)))
  194.  
  195. ;;; (set! x y)  ==>  ($set 'x 'y)
  196. ;;;
  197. ;;; Covert the arguments, set! is retained as a special form.
  198.  
  199. (define (SET!-EXP exp exp-func)
  200.     (if (and (islist exp 3 3) (symbol? (cadr exp)))
  201.     (let ((var (exp-func (cadr exp) exp-func))
  202.           (value (exp-func (caddr exp) exp-func)))
  203.          (set-id-set!! var (if (id-set! var) (+ 1 (id-set! var)) 1))
  204.          `($set ,var ,value))  
  205.     (expand-error 'set exp)))
  206.  
  207. (define ($SET? x) ($SET? x))
  208.  
  209. (define ($SET-ID x) ($SET-ID x))
  210.  
  211. (define ($SET-EXP x) ($SET-EXP x))
  212.  
  213. (define (SET-$SET-EXP! x e) (SET-$SET-EXP! x e))
  214.  
  215. ;;; (if a b [ c ])  ==>  ($if a' b' c')
  216. ;;;            ==>  b'
  217. ;;;            ==>     c'
  218. ;;;
  219. ;;; Convert the arguments, if is retained as a special form.  If the test
  220. ;;; turns out to be a constant expression, then only the appropriate leg of
  221. ;;; the if will be expanded and retained.
  222.  
  223. (define (IF-EXP exp exp-func)
  224.     (cond ((islist exp 3 4)
  225.        (let ((test (exp-func (cadr exp) exp-func))
  226.          (true (caddr exp))
  227.          (false (if (cdddr exp) (cadddr exp) #f)))
  228.         (cond ((and (symbol? test) (eq? (id-use test) 'constant))
  229.                (if (id-value test)
  230.                (exp-func true exp-func)
  231.                (exp-func false exp-func)))
  232.               (else `($if ,test
  233.                   ,(exp-func true exp-func)
  234.                   ,(exp-func false exp-func))))))
  235.       (else (expand-error 'if exp))))
  236.  
  237. (define ($IF? x) ($if? x))
  238.  
  239. (define ($IF-TEST x)($if-test x))
  240.  
  241. (define (SET-$IF-TEST! x test) (set-$if-test! x test))
  242.  
  243. (define ($IF-TRUE x) ($if-true x))
  244.  
  245. (define (SET-$IF-TRUE! x v)(set-$if-true! x v))
  246.  
  247. (define ($IF-FALSE x) ($if-false x))
  248.  
  249. (define (SET-$IF-FALSE! x v) (set-$if-false! x v))
  250.  
  251. ;;; Defines come in two flavors:
  252. ;;;
  253. ;;; (define (f x y ...) body ... )    defines a function.
  254. ;;; (define f body)            defines a top-level variable.
  255. ;;;
  256. ;;; The first is converted to a lambda expression and then processed.  The
  257. ;;; second processed as is.  All forms end up as: ($define id body).
  258.  
  259. (define (DEFINE-EXP exp exp-func)
  260.     (if (and (islist exp 3)
  261.          (or (symbol? (cadr exp))
  262.          (and (pair? (cadr exp)) (symbol? (caadr exp)))))
  263.     (let* ((name   (cadr exp))
  264.            (body   (cddr exp))
  265.            (var    (if (pair? name) (car name) name)))
  266.           (set! current-define-name var)
  267.           (set! var
  268.             (newv var 'use 'global 'module module-name 'defined #t))
  269.           (assign-known-name var)
  270.           (if (pair? name)
  271.           `($define ,var
  272.                ,(exp-func `(lambda ,(cdr name) ,@body) exp-func))
  273.           `($define ,var ,(exp-func (car body) exp-func))))
  274.     (expand-error 'define exp)))
  275.  
  276. (define ($DEFINE? x) ($define? x))
  277.  
  278. (define ($DEFINE-ID x) ($define-id x))
  279.  
  280. (define ($DEFINE-EXP x) ($define-exp x))
  281.  
  282. (define (SET-$DEFINE-EXP! x e) (set-$define-exp! x e))
  283.