home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scsc / lambdaexp.sc < prev    next >
Encoding:
Text File  |  1991-10-11  |  9.3 KB  |  239 lines
  1. ;;; This file contains the functions which handle LAMBDA expressions.  LET
  2. ;;; expressions are converted to LAMBDA expressions to ease later analysis at
  3. ;;; the expense of muddying the intermediate code.
  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 lambdaexp)
  45.  
  46. ;;; External and in-line definitions.
  47.  
  48. (include "plist.sch")
  49. (include "lambdaexp.sch")
  50.  
  51. ;;; (lambda <vars> <body>...)  ==>  ($lambda <id> <body>'...)
  52. ;;;
  53. ;;; Renames variables and then expands the body of the lambda expression.
  54. ;;; The result is a form which contains an id for later reference in <id>,
  55. ;;; and the converted body in <body>'.
  56.  
  57. (define (LAMBDA-EXP exp exp-func)
  58.     (let ((body                           (lambda-defines (cddr exp)))
  59.       (old-lexical-bound-vars   lexical-bound-vars)
  60.       (old-lexical-free-vars    lexical-free-vars)
  61.       (old-current-lambda-id    current-lambda-id)
  62.       (id                    (newv 'l 'use 'lambda))
  63.       (result            '()))
  64.      (set! lexical-free-vars (append lexical-bound-vars lexical-free-vars))
  65.      (set! lexical-bound-vars '())
  66.      (set-lambda-nestin! id current-lambda-id)
  67.      (set! current-lambda-id id)
  68.      (lambda-vars-bind (cadr exp) body id)
  69.      (set! body (exp-form-list body exp-func))
  70.      (set! result `($lambda ,id ,@body))
  71.      (set! lexical-bound-vars old-lexical-bound-vars)
  72.      (set! lexical-free-vars old-lexical-free-vars)
  73.      (set! current-lambda-id old-current-lambda-id)
  74.      result))
  75.  
  76. (define (LAMBDA-VARS-BIND vars name id)
  77.     (cond ((null? vars))
  78.       ((symbol? vars)
  79.        (set! vars (newv vars 'use 'lexical 'boundid id))
  80.        (if name (assign-known-name vars))
  81.        (set-lambda-optvars! id (list vars)))
  82.       ((pair? vars)
  83.        (let ((var (car vars)))
  84.         (set! var (newv var 'use 'lexical 'boundid id))
  85.         (if name (assign-known-name var))
  86.         (lambda-vars-bind (cdr vars) name id)
  87.         (set-lambda-reqvars! id (cons var (lambda-reqvars id)))))
  88.       (else (expand-error 'lambda-variables vars))))
  89.  
  90. ;;; The following procedure is called to rewrite the body of any lambda
  91. ;;; expression which contains DEFINE's to an equivilant lambda form.
  92.  
  93. (define (LAMBDA-DEFINES body)
  94.     (let loop ((oldforms body) (newforms '()) (vars '()) (sets '()))
  95.      (if oldforms
  96.          (let ((form (car oldforms)))
  97.           (cond ((or (not (pair? form))
  98.                  (not (eq? (car form) 'define)))
  99.              (loop (cdr oldforms) (cons form newforms)
  100.                    vars sets))
  101.             ((pair? (cadr form))
  102.              (loop (cdr oldforms) newforms
  103.                    (cons (caadr form) vars)
  104.                    (cons `(set! ,(caadr form)
  105.                         (lambda ,(cdadr form)
  106.                             ,@(cddr form)))
  107.                      sets)))
  108.             (else
  109.              (loop (cdr oldforms) newforms
  110.                    (cons (cadr form) vars)
  111.                    (cons `(set! ,@(cdr form)) sets)))))
  112.          (if vars
  113.          `(((lambda ,vars ,@(reverse sets) ,@(reverse newforms))
  114.             ,@(vector->list (make-vector (length vars) 0))))
  115.          body))))
  116.  
  117. ;;; Attributes of the lambda expression are stored as properties of the <id>:
  118. ;;;
  119. ;;;    REQVARS        list of required arguments
  120. ;;;    OPTVARS        list of optional arguments
  121. ;;;    LEXICAL        lexically bound variables used in <body>
  122. ;;;    CALLS        lambda id's which it uses
  123. ;;;    NAME        name bound to the function
  124. ;;;    GENERATE    indicates code generation strategy.  The possible
  125. ;;;            values are INLINE, INLINE-TAIL, CLOSED-PROCEDURE,
  126. ;;;            and PROCEDURE.
  127. ;;;     CLOSED        lambda expression must be closed.
  128. ;;;     DISPLAY-CLOSEP  closure pointer must be placed in the display.
  129. ;;;     NESTIN        lambda id that this is nested in
  130. ;;;     EXITS           lambda id which this lambda expression exits when it
  131. ;;;                     is tail-called
  132. ;;;     INLINE-TAILS    list of lambda id's for expressions which are tail
  133. ;;;            called to exit this expression
  134. ;;;    STR-CALLS    list of (caller-lambda-id exit-lambda-id) for "self"
  135. ;;;            tail-recursive calls
  136. ;;;    TAIL-CALLS      list of (caller-lambda-id exit-lambda-id) for
  137. ;;;            tail-calls from other lambda expressions
  138. ;;;     REAL-CALLS    list of lambda-id's for "real" (not tail-recursive)
  139. ;;;                calls
  140. ;;;     CODE-LABEL    label for start of function's code
  141. ;;;     $LAMBDA        $lambda expression for in-line compilation
  142.  
  143. (define ($LAMBDA? x) ($lambda? x))
  144.  
  145. (define ($LAMBDA-ID x) ($lambda-id x))
  146.  
  147. (define ($LAMBDA-BODY x) ($lambda-body x))
  148.  
  149. (define (SET-$LAMBDA-BODY! x body) (set-$lambda-body! x body))
  150.  
  151. (define (LAMBDA-REQVARS id) (lambda-reqvars id))
  152.  
  153. (define (SET-LAMBDA-REQVARS! id vars) (set-lambda-reqvars! id vars))
  154.  
  155. (define (LAMBDA-OPTVARS id) (lambda-optvars id))
  156.  
  157. (define (SET-LAMBDA-OPTVARS! id vars) (set-lambda-optvars! id vars))
  158.  
  159. (define (LAMBDA-LEXICAL id) (lambda-lexical id))
  160.  
  161. (define (SET-LAMBDA-LEXICAL! id lexvars) (set-lambda-lexical! id lexvars))
  162.  
  163. (define (LAMBDA-CALLS id) (lambda-calls id))
  164.  
  165. (define (SET-LAMBDA-CALLS! id x)  (set-lambda-calls! id x))
  166.  
  167. (define (LAMBDA-GENERATE id) (lambda-generate id))
  168.  
  169. (define (SET-LAMBDA-GENERATE! id x) (set-lambda-generate! id x))
  170.  
  171. (define (LAMBDA-CLOSED id) (lambda-closed id))
  172.  
  173. (define (SET-LAMBDA-CLOSED! id x) (set-lambda-closed! id x))
  174.  
  175. (define (LAMBDA-DISPLAY-CLOSEP id) (lambda-display-closep id))
  176.  
  177. (define (SET-LAMBDA-DISPLAY-CLOSEP! id x) (set-lambda-display-closep! id x))
  178.     
  179. (define (LAMBDA-NESTIN id) (lambda-nestin id))
  180.  
  181. (define (SET-LAMBDA-NESTIN! id nestin) (set-lambda-nestin! id nestin))
  182.  
  183. (define (LAMBDA-EXITS id) (lambda-exits id))
  184.  
  185. (define (SET-LAMBDA-EXITS! id exits) (set-lambda-exits! id exits))
  186.  
  187. (define (LAMBDA-INLINE-TAILS id) (lambda-inline-tails id))
  188.  
  189. (define (SET-LAMBDA-INLINE-TAILS! id tails)
  190.     (set-lambda-inline-tails! id tails))
  191.     
  192. (define (LAMBDA-STR-CALLS id) (lambda-str-calls id))
  193.  
  194. (define (SET-LAMBDA-STR-CALLS! id x) (set-lambda-str-calls! id x))
  195.     
  196. (define (LAMBDA-TAIL-CALLS id) (lambda-tail-calls id))
  197.  
  198. (define (SET-LAMBDA-TAIL-CALLS! id x) (set-lambda-tail-calls! id x))
  199.     
  200. (define (LAMBDA-REAL-CALLS id) (lambda-real-calls id))
  201.  
  202. (define (SET-LAMBDA-REAL-CALLS! id x) (set-lambda-real-calls! id x))
  203.  
  204. (define (LAMBDA-CODE-LABEL id) (lambda-code-label id))
  205.  
  206. (define (SET-LAMBDA-CODE-LABEL! id x) (set-lambda-code-label! id x))
  207.     
  208. (define (LAMBDA-$LAMBDA id) (lambda-$lambda id))
  209.  
  210. (define (SET-LAMBDA-$LAMBDA! id exp) (set-lambda-$lambda! id exp))
  211.  
  212. (define (LAMBDA-NAME id) (lambda-name id))
  213.  
  214. (define (SET-LAMBDA-NAME! id x) (set-lambda-name! id x))
  215.             
  216. ;;; All information relating to lambda expressions can be dumped by the
  217. ;;; following function.  Note that the body is not printed as it is a little
  218. ;;; large.
  219.  
  220. (define (PRINT-LAMBDA-INFO id  . out)
  221.     (if out (set! out (car out)) (set! out (current-output-port)))
  222.     (format out " LAMBDA-NAME:  ~a ~a ~a~%" (lambda-name id) id
  223.                             (id-printname (or (lambda-name id)
  224.                                   id)))
  225.     (format out "        VARS:  ~a ~a~%"    (lambda-reqvars id)
  226.                             (lambda-optvars id))
  227.     (format out "     LEXICAL:  ~a~%"        (lambda-lexical id))
  228.     (format out "       CALLS:  ~a~%"        (lambda-calls id))
  229.     (format out "    GENERATE:  ~a ~a ~a~%" (lambda-generate id)
  230.                             (lambda-closed id)
  231.                         (lambda-display-closep id))
  232.     (format out "      NESTIN:  ~a~%"        (lambda-nestin id))
  233.     (format out "       EXITS:  ~a~%"       (lambda-exits id))
  234.     (format out "INLINE-TAILS:  ~a~%"       (lambda-inline-tails id))
  235.     (format out "   STR-CALLS:  ~a~%"       (lambda-str-calls id))
  236.     (format out "  TAIL-CALLS:  ~a~%"       (lambda-tail-calls id))
  237.     (format out "  REAL-CALLS:  ~a~%"        (lambda-real-calls id))
  238.     (format out "  CODE-LABEL:  ~a~%"       (lambda-code-label id)))
  239.