home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / compiler.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  32.5 KB  |  780 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: compiler.scm,v 1.26 1992/09/11 21:24:20 jmiller Exp $
  39.  
  40. ;;;; This file contains the Thomas -> Scheme compiler and
  41. ;;;; routines needed ONLY at compilation time.  Support routines that
  42. ;;;; are also needed when Dylan programs run are located in generic.scm
  43. ;;;; (generic operator dispatch), class.scm (class heterarchy), and
  44. ;;;; support.scm (general support routines)
  45.  
  46. ;;; Normal external entry points for compilation
  47.  
  48. (define (compile-expression e multi-value mod-vars continue)
  49.   ;; e is a single Thomas expression
  50.   ;; multi-value is an expression to be passed as the multi-value
  51.   ;;  vector (or #F) at runtime
  52.   ;; mod-vars is a list of pre-existing module variables
  53.   ;; continue is a function that receives:
  54.   ;;   a: the output code
  55.   ;;   b: the preamble (def'ns of free variables, refs, sets)
  56.   ;;   c: the list of newly created module variables
  57.   (define (define-module-variable name)
  58.     `(DEFINE ,name ',the-unassigned-value))
  59.   (define (define-module-getter name)
  60.     `(DEFINE (,(name->module-getter name)) ,name))
  61.   (define (define-module-setter name)
  62.     `(DEFINE (,(name->module-setter name) NEW-VALUE)
  63.        (SET! ,name NEW-VALUE)))
  64.   (really-compile e mod-vars '() multi-value
  65.    (lambda (compiled-output free-vars)
  66.      (let* ((need-getter/setters
  67.          (if (null? free-vars)
  68.          '()
  69.          (set-difference free-vars mod-vars member)))
  70.         (need-definition
  71.          (set-difference need-getter/setters
  72.                  dylan::predefined-variables member)))
  73.        (continue need-definition
  74.          `(,@(map define-module-variable need-definition)
  75.            ,@(map define-module-getter need-getter/setters)
  76.            ,@(map define-module-setter need-getter/setters))
  77.          compiled-output)))))
  78.  
  79. (define dylan::scheme-names-of-predefined-names
  80.   `((* dylan:*)                        ; Method
  81.     (+ dylan:+)                        ; Method
  82.     (- dylan:-)                        ; Method
  83.     (/ dylan:/)                        ; Method
  84.     (/= dylan:/=)                    ; Method
  85.     (< dylan:<)                        ; Method
  86.     (<= dylan:<=)                    ; Method
  87.     (<abort> <abort>)                    ; Class
  88.     (<array> <array>)                    ; Class
  89.     (<byte-string> <byte-string>)            ; Class
  90.     (<character> <character>)                ; Class
  91.     (<class> <class>)                    ; Class
  92.     (<collection> <collection>)                ; Class
  93.     (<complex> <complex>)                ; Class
  94.     (<condition> <condition>)                ; Class
  95.     (<deque> <deque>)                    ; Class
  96.     (<double-float> <double-float>)            ; Class
  97.     (<empty-list> <empty-list>)                ; Class
  98.     (<error> <error>)                    ; Class
  99.     (<explicit-key-collection>                ; Class
  100.      <explicit-key-collection>)
  101.     (<extended-float> <extended-float>)            ; Class
  102.     (<float> <float>)                    ; Class
  103.     (<function> <function>)                ; Class
  104.     (<generic-function> <generic-function>)        ; Class
  105.     (<integer> <integer>)                ; Class
  106.     (<keyword> <keyword>)                ; Class
  107.     (<list> <list>)                    ; Class
  108.     (<method> <method>)                    ; Class
  109.     (<mutable-collection> <mutable-collection>)        ; Class
  110.     (<mutable-explicit-key-collection>            ; Class
  111.      <mutable-explicit-key-collection>)
  112.     (<mutable-sequence> <mutable-sequence>)         ; Class
  113.     (<number> <number>)                    ; Class
  114.     (<object> <object>)                    ; Class
  115.     (<pair> <pair>)                    ; Class
  116.     (<range> <range>)                    ; Class
  117.     (<ratio> <ratio>)                    ; Class
  118.     (<rational> <rational>)                ; Class
  119.     (<real> <real>)                    ; Class
  120.     (<rectangular-complex> <rectangular-complex>)   ; Class
  121.     (<restart> <restart>)                ; Class
  122.     (<sequence> <sequence>)                ; Class
  123.     (<serious-condition> <serious-condition>)        ; Class
  124.     (<simple-error> <simple-error>)            ; Class
  125.     (<simple-object-vector> <simple-object-vector>) ; Class
  126.     (<simple-restart> <simple-restart>)            ; Class
  127.     (<simple-warning> <simple-warning>)            ; Class
  128.     (<single-float> <single-float>)            ; Class
  129.     (<singleton> <singleton>)                ; Class
  130.     (<slot-descriptor> <slot-descriptor>)        ; Class
  131.     (<stretchy-vector> <stretchy-vector>)        ; Class
  132.     (<string> <string>)                    ; Class
  133.     (<symbol> <symbol>)                    ; Class
  134.     (<table> <table>)                    ; Class
  135.     (<type-error> <type-error>)                ; Class
  136.     (<unicode-string> <unicode-string>)            ; Class
  137.     (<vector> <vector>)                    ; Class
  138.     (<warning> <warning>)                ; Class
  139.     (= dylan:=)                        ; Method
  140.     (=hash dylan:=hash)                    ; Generic-Function
  141.     (> dylan:>)                        ; Method
  142.     (>= dylan:>=)                    ; Method
  143.     (Id? dylan:id?)                    ; Method
  144.     (abort dylan:abort)                    ; Sealed-Function
  145.     (abs dylan:abs)                    ; Generic-Function
  146.     (acos dylan:acos)                    ; Generic-Function
  147.     (acosh dylan:acosh)                    ; Generic-Function
  148.     (add dylan:add)                    ; Generic-Function
  149.     (add! dylan:add!)                    ; G.F. Method
  150.     (add-method dylan:add-method)            ; Generic-Function
  151.     (add-new dylan:add-new)                ; Generic-Function
  152.     (add-new! dylan:add-new!)                ; Generic-Function
  153.     (add-slot dylan:add-slot)                ; Generic-Function
  154.     (all-superclasses dylan:all-superclasses)       ; Generic-Function
  155.     (always dylan:always)                ; Method
  156.     (angle dylan:angle)                    ; Generic-Method
  157.     (any? dylan:any?)                    ; Generic-Function
  158.     (append dylan:append)                ; Generic-Function
  159.     (applicable-method? dylan:applicable-method?)   ; Generic-Function
  160.     (apply dylan:apply)                    ; Function
  161.     (aref dylan:aref)                    ; Generic-Function
  162.     (as dylan:as)                    ; Generic-Function
  163.     (as-lowercase dylan:as-lowercase)                ; G.F. Method
  164.     (as-lowercase! dylan:as-lowercase!)            ; G.F. Method
  165.     (as-uppercase dylan:as-uppercase)            ; G.F. Method
  166.     (as-uppercase! dylan:as-uppercase!)            ; G.F. Method
  167.     (ash dylan:ash)                    ; Generic-Method
  168.     (asin dylan:asin)                    ; Generic-Function
  169.     (asinh dylan:asinh)                    ; Generic-Function
  170.     (atan dylan:atan)                    ; Generic-Function
  171.     (atan2 dylan:atan2)                    ; Generic-Function
  172.     (atanh dylan:atanh)                    ; Generic-Function
  173.     (binary* dylan:binary*)                ; Generic-Function
  174.     (binary+ dylan:binary+)                ; Generic-Function
  175.     (binary- dylan:binary-)                ; Generic-Function
  176.     (binary-gcd dylan:binary-gcd)            ; Generic-Method
  177.     (binary-lcm dylan:binary-lcm)            ; Generic-Method
  178.     (binary/ dylan:binary/)                ; Generic-Function
  179.     (binary< dylan:binary<)                ; Generic-Function
  180.     (binary= dylan:binary=)                ; Generic-Function
  181.     (break dylan:break)                    ; Sealed-Function
  182.     (caaar dylan:caaar)                    ; Method
  183.     (caadr dylan:caadr)                    ; Method
  184.     (caar dylan:caar)                    ; Method
  185.     (cadar dylan:cadar)                    ; Method
  186.     (caddr dylan:caddr)                    ; Method
  187.     (cadr dylan:cadr)                    ; Method
  188.     (car dylan:car)                    ; Method
  189.     (cdaar dylan:cdaar)                    ; Method
  190.     (cdadr dylan:cdadr)                    ; Method
  191.     (cdar dylan:cdar)                    ; Method
  192.     (cddar dylan:cddar)                    ; Method
  193.     (cdddr dylan:cdddr)                    ; Method
  194.     (cddr dylan:cddr)                    ; Method
  195.     (cdr dylan:cdr)                    ; Method
  196.     (ceiling dylan:ceiling)                ; Generic-Function
  197.     (ceiling/ dylan:ceiling/)                ; Generic-Function
  198.     (cerror dylan:cerror)                ; Sealed-Function
  199.     (check-type dylan:check-type)            ; Sealed-Function
  200.     (choose dylan:choose)                ; Generic-Function
  201.     (choose-by dylan:choose-by)                ; Generic-Function
  202.     (class-for-copy dylan:class-for-copy)           ; Generic-Function
  203.     (complement dylan:complement)            ; Method
  204.     (compose dylan:compose)                ; Method
  205.     (concatenate dylan:concatenate)            ; Generic-Function
  206.     (concatenate-as dylan:concatenate-as)        ; Generic-Function
  207.     (conjoin dylan:conjoin)                ; Method
  208.     (cons dylan:cons)                    ; Method
  209.     (copy-sequence dylan:copy-sequence)            ; Generic-Function
  210.     (copy-state dylan:copy-state)            ; Generic-Function
  211.     (cos dylan:cos)                    ; Generic-Function
  212.     (cosh dylan:cosh)                    ; Generic-Function
  213.     (current-element dylan:current-element)        ; Generic-Function
  214.     (current-key dylan:current-key)            ; Generic-Function
  215.     (curry dylan:curry)                    ; Method
  216.     (default-handler dylan:default-handler)        ; Generic-Function
  217.     (denominator dylan:denominator)            ; Generic-Method
  218.     (dimensions dylan:dimensions)            ; Generic-Function
  219.     (direct-subclasses dylan:direct-subclasses)        ; Generic-Function
  220.     (direct-superclasses dylan:direct-superclasses) ; Generic-Function
  221.     (disjoin dylan:disjoin)                ; Method
  222.     (do dylan:do)                        ; Generic-Function
  223.     (do-handlers dylan:do-handlers)            ; Sealed-Function
  224.     (element dylan:element)                ; Generic-Function
  225.     (empty? dylan:empty?)                ; Generic-Function
  226.     (error dylan:error)                        ; Sealed-Function
  227.     (even? dylan:even?)                    ; Generic-Function
  228.     (every? dylan:every?)                ; Generic-Function
  229.     (exp dylan:exp)                    ; Generic-Function
  230.     (expt dylan:expt)                    ; Generic-Function
  231.     (fill! dylan:fill!)                    ; Generic-Function
  232.     (final-state dylan:final-state)            ; G.F. Method
  233.     (find-key dylan:find-key)                ; Generic-Function
  234.     (find-method dylan:find-method)            ; Generic-Function
  235.     (find-pair dylan:find-pair)                ; Generic-Function
  236.     (first dylan:first)                    ; Generic-Function
  237.     (floor dylan:floor)                    ; Generic-Function
  238.     (floor/ dylan:floor/)                ; Generic-Function
  239.     (freeze-methods dylan:freeze-methods)        ; Generic-Function
  240.     (function-arguments dylan:function-arguments)   ; Generic-Function
  241.     (gcd dylan:gcd)                    ; Method
  242.     (generic-function-methods                ; Generic-Function
  243.      dylan:generic-function-methods)
  244.     (identity dylan:identity)                ; Method
  245.     (imag-part dylan:imag-part)                ; Generic-Method
  246.     (init-function dylan:init-function)            ; Generic-Function
  247.     (init-keyword dylan:init-keyword)            ; Generic-Function
  248.     (init-value dylan:init-value)            ; Generic-Function
  249.     (initial-state dylan:initial-state)            ; Generic-Function
  250.     (initialize dylan:initialize)            ; Generic-Function
  251.     (instance? dylan:instance?)                ; Generic-Function
  252.     (integral? dylan:integral?)                ; Generic-Function
  253.     (intersection dylan:intersection)            ; Generic-Function
  254.     (key-sequence dylan:key-sequence)            ; Generic-Function
  255.     (last dylan:last)                    ; Generic-Function
  256.     (lcm dylan:lcm)                    ; Method
  257.     (list dylan:list)                    ; Method
  258.     (list* dylan:list*)                    ; Method
  259.     (log dylan:log)                    ; Generic-Function
  260.     (logand dylan:logand)                ; Generic-Method
  261.     (logandc1 dylan:logandc1)                ; Generic-Method
  262.     (logandc2 dylan:logandc2)                ; Generic-Method
  263.     (logbit? dylan:logbit?)                ; Generic-Method
  264.     (logeqv dylan:logeqv)                ; Generic-Method
  265.     (logior dylan:logior)                ; Generic-Method
  266.     (lognand dylan:lognand)                ; Generic-Method
  267.     (lognor dylan:lognor)                ; Generic-Method
  268.     (lognot dylan:lognot)                ; Generic-Method
  269.     (logorc1 dylan:logorc1)                ; Generic-Method
  270.     (logorc2 dylan:logorc2)                ; Generic-Method
  271.     (logxor dylan:logxor)                ; Generic-Method
  272.     (make dylan:make)                    ; Generic-Function
  273.     (make-polar dylan:make-polar)            ; Generic-Function
  274.     (make-read-only dylan:make-read-only)        ; Generic-Function
  275.     (make-rectangular dylan:make-rectangular)        ; Generic-Function
  276.     (map dylan:map)                    ; Generic-Function
  277.     (map-as dylan:map-as)                ; Generic-Function
  278.     (map-into dylan:map-into)                ; Generic-Function
  279.     (max dylan:max)                    ; Method
  280.     (member? dylan:member?)                ; Generic-Function
  281.     (method-specializers dylan:method-specializers) ; Generic-Function
  282.     (min dylan:min)                    ; Method
  283.     (modulo dylan:modulo)                ; Generic-Function
  284.     (negative? dylan:negative?)                ; Generic-Function
  285.     (next-state dylan:next-state)            ; Generic-Function
  286.     (not dylan:not)                    ; Function
  287.     (numerator dylan:numerator)                ; Generic-Method
  288.     (object-class dylan:object-class)            ; Generic-Function
  289.     (odd? dylan:odd?)                    ; Generic-Function
  290.     (pop dylan:pop)                    ; Generic-Function
  291.     (pop-last dylan:pop-last)                ; Generic-Function
  292.     (positive? dylan:positive?)                ; Generic-Function
  293.     (previous-state dylan:previous-state)        ; G.F. Method
  294.     (push dylan:push)                    ; Generic-Function
  295.     (push-last dylan:push-last)                ; Generic-Function
  296.     (range dylan:range)                    ; Generic-Function
  297.     (rcurry dylan:rcurry)                ; Method
  298.     (real-part dylan:real-part)                ; Generic-Method
  299.     (rationalize dylan:rationalize)            ; Generic-Method
  300.     (reduce dylan:reduce)                ; Generic-Function
  301.     (reduce1 dylan:reduce1)                ; Generic-Function
  302.     (remainder dylan:remainder)                ; Generic-Function
  303.     (remove dylan:remove)                ; Generic-Function
  304.     (remove! dylan:remove!)                ; Generic-Function
  305.     (remove-duplicates dylan:remove-duplicates)        ; Generic-Function
  306.     (remove-duplicates! dylan:remove-duplicates!)   ; Generic-Function
  307.     (remove-key! dylan:remove-key!)            ; Generic-Function
  308.     (remove-method dylan:remove-method)            ; Generic-Function
  309.     (remove-slot dylan:remove-slot)            ; Generic-Function
  310.     (replace-elements! dylan:replace-elements!)        ; Generic-Function
  311.     (replace-subsequence! dylan:replace-subsequence!) ; Generic-Function
  312.     (restart-query dylan:restart-query)            ; Generic-Function
  313.     (return-allowed? dylan:return-allowed?)        ; Generic-Function
  314.     (return-description dylan:return-description)   ; Generic-Function
  315.     (return-query dylan:return-query)            ; Generic-Function
  316.     (reverse dylan:reverse)                ; Generic-Function
  317.     (reverse! dylan:reverse!)                ; Generic-Function
  318.     (round dylan:round)                    ; Generic-Function
  319.     (round/ dylan:round/)                ; Generic-Function
  320.     (seal dylan:seal)                    ; Generic-Function
  321.     (second dylan:second)                ; Generic-Function
  322.     (shallow-copy dylan:shallow-copy)            ; Generic-Function
  323.     (signal dylan:signal)                ; Sealed-Function
  324.     (sin dylan:sin)                    ; Generic-Function
  325.     (singleton dylan:singleton)                ; Function
  326.     (sinh dylan:sinh)                    ; Generic-Function
  327.     (size dylan:size)                    ; G.F. Method
  328.     (slot-allocation dylan:slot-allocation)        ; Generic-Function
  329.     (slot-descriptor dylan:slot-descriptor)        ; Generic-Function
  330.     (slot-descriptors dylan:slot-descriptors)       ; Generic-Function
  331.     (slot-getter dylan:slot-getter)            ; Generic-Function
  332.     (slot-initialized? dylan:slot-initialized?)        ; Generic-Function
  333.     (slot-setter dylan:slot-setter)            ; Generic-Function
  334.     (slot-type dylan:slot-type)                ; Generic-Function
  335.     (slot-value dylan:slot-value)            ; Generic-Function
  336.     (sort dylan:sort)                    ; Generic-Function
  337.     (sort! dylan:sort!)                    ; Generic-Function
  338.     (sorted-applicable-methods                ; Generic-Function
  339.      dylan:sorted-applicable-methods)
  340.     (sqrt dylan:sqrt)                    ; Generic-Method
  341.     (subclass? dylan:subclass?)                ; Generic-Function
  342.     (subsequence-position dylan:subsequence-position) ; Generic-Function
  343.     (tan dylan:tan)                    ; Generic-Function
  344.     (tanh dylan:tanh)                    ; Generic-Function
  345.     (third dylan:third)                    ; Generic-Function
  346.     (truncate dylan:truncate)                ; Generic-Function
  347.     (truncate/ dylan:truncate/)                ; Generic-Function
  348.     (unary- dylan:unary-)                ; Generic-Function
  349.     (unary/ dylan:unary/)                ; Generic-Function
  350.     (union dylan:union)                    ; Generic-Function
  351.     (values dylan:values)                ; Function
  352.     (vector dylan:vector)                ; Method
  353.     (zero? dylan:zero?)                    ; Generic-Function
  354.     ;;;;;;;;;;;;;;; SETTER VARIABLES
  355.     (,(name->setter 'slot-value) dylan:setter/slot-value/)
  356.     (,(name->setter 'element) dylan:setter/element/)
  357.     (,(name->setter 'current-element) dylan:setter/current-element/)
  358.     (,(name->setter 'first) dylan:setter/first/)
  359.     (,(name->setter 'second) dylan:setter/second/)
  360.     (,(name->setter 'third) dylan:setter/third/)
  361.     (,(name->setter 'aref) dylan:setter/aref/)
  362.     (,(name->setter 'car) dylan:setter/car/)
  363.     (,(name->setter 'cdr) dylan:setter/cdr/)
  364.     (,(name->setter 'caar) dylan:setter/caar/)
  365.     (,(name->setter 'cadr) dylan:setter/cadr/)
  366.     (,(name->setter 'cdar) dylan:setter/cdar/)
  367.     (,(name->setter 'cddr) dylan:setter/cddr/)
  368.     (,(name->setter 'caaar) dylan:setter/caaar/)
  369.     (,(name->setter 'caadr) dylan:setter/caadr/)
  370.     (,(name->setter 'cadar) dylan:setter/cadar/)
  371.     (,(name->setter 'caddr) dylan:setter/caddr/)
  372.     (,(name->setter 'cdaar) dylan:setter/cdaar/)
  373.     (,(name->setter 'cdadr) dylan:setter/cdadr/)
  374.     (,(name->setter 'cddar) dylan:setter/cddar/)
  375.     (,(name->setter 'cdddr) dylan:setter/cdddr/)
  376.     ;;;;;;;;;;;;;;; CRL ADDITIONS
  377.     (display dylan:display)
  378.     (newline dylan:newline)
  379.     (write-line dylan:write-line)
  380.     (print dylan:print)
  381.     ,@implementation-specific:additional-dylan-bindings
  382.     ))
  383.  
  384. (define dylan::predefined-names
  385.   (map car dylan::scheme-names-of-predefined-names))
  386.  
  387. (define dylan::predefined-variables
  388.   (map cadr dylan::scheme-names-of-predefined-names))
  389.  
  390. (define (thomas file-name . expressions)
  391.   (compile-expression `(BEGIN ,@expressions) #F '()
  392.     (lambda (new-vars preamble-code compiled)
  393.       new-vars                ; Not used
  394.       (with-output-to-file file-name
  395.     (lambda ()
  396.       (display "; Output generated by the CRL Thomas->Scheme compiler.")
  397.       (newline)
  398.       (implementation-specific:generate-file
  399.        expressions
  400.        `(dylan::catch-all-conditions
  401.          (lambda () ,@preamble-code ,compiled))))))))
  402.  
  403. (define (thomas->scheme input output)
  404.   (let ((in-port (open-input-file input)))
  405.     (let loop ((exprs '()))
  406.       (let ((next (read in-port)))
  407.     (if (eof-object? next)
  408.         (thomas output `(BEGIN ,@(reverse exprs)))
  409.         (loop (cons next exprs)))))))
  410.  
  411. ;;; Compile a list of forms, returning a list of Scheme expressions
  412. ;;; ASSUMPUTION: multiple-values?, if not #F, is to be used only for
  413. ;;; compiling the last of the forms.
  414.  
  415. (define (compile-forms
  416.      forms module-vars bound-vars really-compile
  417.      multiple-values? continue)
  418.   (let loop ((result '())
  419.          (forms forms)
  420.          (mod-vars module-vars))
  421.     (if (null? forms)
  422.     (continue (reverse result) mod-vars)
  423.     (really-compile (car forms) mod-vars bound-vars
  424.             (if (null? (cdr forms)) multiple-values? #F)
  425.       (lambda (compiled mod-vars)
  426.         (loop (cons compiled result)
  427.           (cdr forms)
  428.           mod-vars))))))
  429.  
  430. ;;; The real compiler.
  431. ;;;
  432. ;;; Input: e is a form to be compiled
  433. ;;;        module-vars are the module variables already known to exist
  434. ;;;        bound-vars are the names of lexically enclosing variables
  435. ;;;        multiple-values? is either #F, indicating that the current
  436. ;;;          expressions is being compiled in non-tail position or has
  437. ;;;          the name of an internal variable to be used at runtime to
  438. ;;;          transmit the multiple-value returning function along the
  439. ;;;          tail call chain.
  440. ;;;        continue is called with the result of the compilation, and
  441. ;;;          is passed the single SCHEME form resulting from compiling
  442. ;;;          e and the new list of module variables.
  443. ;;; Output: always either error exits or tail calls into continue
  444.  
  445. (define (really-compile e module-vars bound-vars
  446.             multiple-values? continue)
  447.   (cond
  448.    ((or (null? e) (boolean? e) (string? e)
  449.     (char? e) (number? e))        ; syntax might be an issue...
  450.     (continue e module-vars))
  451.    ((or (vector? e) (keyword? e))    ; Keywords self-evaluate in
  452.                     ; Dylan, but not in Scheme
  453.     (continue `(QUOTE ,e) module-vars))
  454.    ((variable-name? e)
  455.     ;; As in Scheme, but the compiler needs to distinguish  bound from
  456.     ;; free
  457.     (let* ((name (variable->name e))
  458.        (new-mod-vars (add-variable name bound-vars module-vars)))
  459.       (continue
  460.        (if (memq name new-mod-vars)
  461.        `(DYLAN::FREE-VARIABLE-REF ,name ',name)
  462.        name)
  463.        new-mod-vars)))
  464.    ((symbol? e)
  465.     (dylan::error "illegal Thomas variable" e))
  466.    ((and (pair? e) (assq (car e) compilation-functions)) =>
  467.     (lambda (binding)
  468.       (((cdr binding)) (cdr e) module-vars bound-vars
  469.                really-compile multiple-values? continue)))
  470.    ((and (list? e) (not (null? e)))
  471.     (compile-forms e module-vars bound-vars really-compile #F
  472.            (lambda (forms module-vars)
  473.              (continue
  474.               `(DYLAN::APPLY ,multiple-values?
  475.                      ,@(map (lambda (x) `(LAMBDA () ,x))
  476.                         forms))
  477.                    module-vars))))
  478.    (else
  479.     (dylan::error "ill-formed expression" e))))
  480.  
  481. (define compiled-sharp-f
  482.   (really-compile #F '() '() #F (lambda (compiled free)
  483.                   free    ; Ignored
  484.                   compiled)))
  485.  
  486. (define compilation-functions
  487.   `((AND            . ,(lambda () compile-AND-form))
  488.     (BEGIN          . ,(lambda () compile-BEGIN-form))
  489.     (BIND           . ,(lambda () compile-BIND-form))
  490.     (BIND-EXIT      . ,(lambda () compile-BIND-EXIT-form))
  491.     (BIND-METHODS   . ,(lambda () compile-BIND-METHODS-form))
  492.     (CASE           . ,(lambda () compile-CASE-form))
  493.     (COND           . ,(lambda () compile-COND-form))
  494.     (DEFINE         . ,(lambda () compile-DEFINE-form))
  495.     (DEFINE-CLASS   . ,(lambda () compile-DEFINE-CLASS-form))
  496.     (DEFINE-GENERIC-FUNCTION .
  497.       ,(lambda () compile-DEFINE-GENERIC-FUNCTION-form))
  498.     (DEFINE-METHOD  . ,(lambda () compile-DEFINE-METHOD-form))
  499.     (DEFINE-SLOT    . ,(lambda () compile-DEFINE-SLOT-form))
  500.     (DOTIMES        . ,(lambda () compile-DOTIMES-form))
  501.     (FOR            . ,(lambda () compile-FOR-form))
  502.     (FOR-EACH       . ,(lambda () compile-FOR-EACH-form))
  503.     (HANDLER-BIND   . ,(lambda () compile-HANDLER-BIND-form))
  504.     (HANDLER-CASE   . ,(lambda () compile-HANDLER-CASE-form))
  505.     (IF             . ,(lambda () compile-IF-form))
  506.     (METHOD         . ,(lambda () compile-METHOD-form))
  507.     (OR             . ,(lambda () compile-OR-form))
  508.     (QUOTE          . ,(lambda () compile-QUOTE-form))
  509.     (SELECT         . ,(lambda () compile-SELECT-form))
  510.     (SET!           . ,(lambda () compile-SET!-form))
  511.     (SETTER         . ,(lambda () compile-SETTER-form))
  512.     (UNLESS         . ,(lambda () compile-UNLESS-form))
  513.     (UNTIL          . ,(lambda () compile-UNTIL-form))
  514.     (UNWIND-PROTECT . ,(lambda () compile-UNWIND-PROTECT-form))
  515.     (WHEN           . ,(lambda () compile-WHEN-form))
  516.     (WHILE          . ,(lambda () compile-WHILE-form))))
  517.  
  518. (define (compile-AND-form forms module-vars bound-vars really-compile
  519.               multiple-values? continue)
  520.    (if (null? forms) (dylan::error "AND must have forms"))
  521.    (compile-forms
  522.     forms module-vars bound-vars really-compile multiple-values?
  523.     (lambda (code mod-vars) (continue `(AND ,@code) mod-vars))))
  524.  
  525. (define (compile-BEGIN-form forms module-vars bound-vars really-compile
  526.         multiple-values? continue)
  527.    (if (null? forms)
  528.        (continue compiled-sharp-f module-vars)
  529.        (compile-forms
  530.     forms module-vars bound-vars
  531.     really-compile multiple-values?
  532.     (lambda (compiled module-vars)
  533.       (continue `(BEGIN ,@compiled) module-vars)))))
  534.  
  535. ; compile-BIND-form in file comp-class
  536.  
  537. (define (compile-BIND-EXIT-form
  538.      forms module-vars bound-vars really-compile multiple-values?
  539.      continue)
  540.   (must-be-list-of-at-least-length forms 1 "BIND-EXIT form invalid")
  541.   (let ((var (car forms))
  542.     (forms (cdr forms)))
  543.     (must-be-list-of-length var 1 "BIND-EXIT bad variable")
  544.     (if (not (variable-name? (car var)))
  545.     (dylan::error "BIND-EXIT -- bad variable name" var forms))
  546.     (let ((name (variable->name (car var))))
  547.       (really-compile
  548.        `(BEGIN ,@forms)
  549.        module-vars (cons name bound-vars) multiple-values?
  550.        (lambda (body module-vars)
  551.      (continue
  552.       `(DYLAN::CALL/CC
  553.         (LAMBDA (!BIND-EXIT)
  554.           (LET ((,name
  555.              (LAMBDA (!MULTIPLE-VALUES !NEXT-METHOD . VALUES)
  556.                !MULTIPLE-VALUES !NEXT-METHOD
  557.                (!BIND-EXIT
  558.             (DYLAN::SCHEME-APPLY
  559.              DYLAN:VALUES ,multiple-values?
  560.              NEXT-METHOD:NOT-GENERIC
  561.              VALUES)))))
  562.         ,body)))
  563.       module-vars))))))
  564.  
  565. ; compile-BIND-METHODS-form in file comp-method.scm
  566. ; compile-CASE-form in file comp-sf
  567. ; compile-COND-form in file comp-sf
  568.  
  569. (define (compile-DEFINE-form
  570.      forms module-vars bound-vars really-compile
  571.      multiple-values? continue)
  572.   multiple-values?            ; No reductions
  573.   (must-be-list-of-length forms 2 "Bad DEFINE syntax")
  574.   (let ((name (car forms))
  575.     (value (cadr forms)))
  576.     (if (not (variable-name? name))
  577.     (dylan::error "bad DEFINE variable" forms))
  578.     (really-compile value
  579.       (add-module-variable (variable->name name) #F module-vars)
  580.       bound-vars #F
  581.       (lambda (compiled-value new-module-vars)
  582.     (continue
  583.      `(BEGIN
  584.         (,(name->module-setter name) ,compiled-value)
  585.         ',name)
  586.      new-module-vars)))))
  587.  
  588. ; compile-DEFINE-CLASS-form in file comp-class
  589. ; compile-DEFINE-GENERIC-FUNCTION-form in file comp-class
  590. ; compile-DEFINE-METHOD-form in file comp-method
  591. ; compile-DEFINE-SLOT-form in file comp-class
  592.  
  593. (define (compile-DOTIMES-form
  594.      forms module-vars bound-vars really-compile
  595.      multiple-values? continue)
  596.     (must-be-list-of-at-least-length forms 1 "DOTIMES: bad syntax")
  597.     (let ((v/c/r (car forms))
  598.       (forms (cdr forms)))
  599.       (must-be-list-of-at-least-length v/c/r 2
  600.        "DOTIMES: Bad var/count/result list")
  601.       (let ((var (car v/c/r))
  602.         (count-form (cadr v/c/r))
  603.         (result (if (pair? (cddr v/c/r)) (caddr v/c/r) #F)))
  604.     (if (not (variable-name? var))
  605.         (dylan::error "DOTIMES -- invalid variable" var forms))
  606.     (if (not (or (null? (cddr v/c/r))
  607.              (null? (cdddr v/c/r))))
  608.         (dylan::error "DOTIMES -- bad syntax"))
  609.     (let ((name (variable->name var)))
  610.       (compile-forms
  611.        forms module-vars (cons name bound-vars) really-compile #F
  612.        (lambda (body-forms module-vars)
  613.          (compile-forms
  614.           (list count-form result)
  615.           module-vars bound-vars really-compile multiple-values?
  616.           (lambda (c/r-code module-vars)
  617.         (continue
  618.          `(DYLAN::DOTIMES ,(car c/r-code)
  619.                   (LAMBDA () ,(cadr c/r-code))
  620.                   (LAMBDA (,name) ,@body-forms))
  621.          module-vars)))))))))
  622.  
  623. ; compile-FOR-form in file comp-sf
  624.  
  625. (define (compile-FOR-EACH-form
  626.      forms module-vars bound-vars really-compile
  627.      multiple-values? continue)
  628.     (must-be-list-of-at-least-length forms 2 "FOR-EACH: bad syntax")
  629.     (for-each
  630.      (lambda (binding)
  631.        (must-be-list-of-length binding 2 "FOR-EACH: bad binding"))
  632.      (car forms))
  633.     (let ((names (map car (car forms)))
  634.       (collections (map cadr (car forms)))
  635.       (end-test-and-return-vals (cadr forms))
  636.       (forms (cddr forms)))
  637.       (compile-forms
  638.        collections module-vars bound-vars really-compile #F
  639.        (lambda (compiled-collections module-vars)
  640.      (compile-forms
  641.       (if (null? end-test-and-return-vals)
  642.           '(#F)
  643.           end-test-and-return-vals)
  644.       module-vars
  645.       (append names bound-vars) really-compile multiple-values?
  646.       (lambda (compiled-et module-vars)
  647.         (compile-forms
  648.          forms module-vars (append names bound-vars)
  649.          really-compile #F
  650.          (lambda (compiled-forms module-vars)
  651.            (continue
  652.         `(DYLAN::FOR-EACH
  653.           (LAMBDA (!MULTIPLE-VALUES !DYLAN:NEXT-METHOD ,@names)
  654.             !MULTIPLE-VALUES    ; Ignored
  655.             !DYLAN:NEXT-METHOD    ; Ignored
  656.             ,(if (null? end-test-and-return-vals)
  657.              `(BEGIN ,@compiled-forms #F)
  658.              `(IF ,(car compiled-et)
  659.                   (DYLAN::LIST ,@(if (null? (cdr compiled-et))
  660.                          (list compiled-sharp-f)
  661.                          (cdr compiled-et)))
  662.                   (BEGIN ,@compiled-forms #F))))
  663.           ,@compiled-collections)
  664.         module-vars)))))))))
  665.  
  666. ; compile-HANDLER-BIND-form in file comp-exc
  667. ; compile-HANDLER-CASE-form in file comp-exc
  668.  
  669. (define (compile-IF-form forms module-vars bound-vars really-compile
  670.              multiple-values? continue)
  671.     (must-be-list-of-length forms 3 "IF: invalid syntax")
  672.     (let ((pred (car forms))
  673.       (conseq (cadr forms))
  674.       (alter (caddr forms)))
  675.       (really-compile pred module-vars bound-vars #F
  676.     (lambda (c-pred module-vars)
  677.       (really-compile conseq module-vars
  678.               bound-vars multiple-values?
  679.         (lambda (c-conseq module-vars)
  680.           (really-compile alter module-vars
  681.                   bound-vars multiple-values?
  682.             (lambda (c-alter module-vars)
  683.           (continue `(IF ,c-pred ,c-conseq ,c-alter)
  684.                 module-vars)))))))))
  685.  
  686. ; compile-METHOD-form in file comp-method
  687.  
  688. (define (compile-OR-form
  689.      forms module-vars bound-vars really-compile
  690.      multiple-values? continue)
  691.   (compile-forms
  692.    forms module-vars bound-vars really-compile multiple-values?
  693.    (lambda (code mod-vars)
  694.      (continue `(OR ,@code) mod-vars))))
  695.  
  696. (define (compile-QUOTE-form forms module-vars bound-vars really-compile
  697.          multiple-values? continue)
  698.   bound-vars really-compile multiple-values?
  699.   (must-be-list-of-length forms 1 "QUOTE: invalid syntax")
  700.   (continue `(QUOTE ,@forms) module-vars))
  701.  
  702. ; compile-SELECT-form in file comp-sf
  703. ; compile-SET!-form in file
  704.  
  705. (define (compile-SETTER-form forms module-vars bound-vars really-compile
  706.                  multiple-values? continue)
  707.   forms module-vars bound-vars really-compile
  708.   multiple-values? continue
  709.   (dylan::error "bad SETTER syntax" forms))
  710.  
  711. (define (compile-UNLESS-form
  712.      forms module-vars bound-vars
  713.      really-compile multiple-values? continue)
  714.   bound-vars                ; Ignored
  715.   (must-be-list-of-at-least-length forms 1 "UNLESS: bad syntax")
  716.   (compile-forms forms module-vars bound-vars really-compile
  717.          (if (null? (cdr forms)) #F multiple-values?)
  718.     (lambda (forms module-vars)
  719.       (continue
  720.        `(IF (DYLAN::NOT ,(car forms))
  721.         (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  722.         #F)
  723.        module-vars))))
  724.  
  725. (define (compile-UNTIL-form
  726.      forms module-vars bound-vars really-compile
  727.      multiple-values? continue)
  728.   multiple-values?
  729.   (must-be-list-of-at-least-length forms 2 "UNTIL: bad syntax")
  730.   (compile-forms forms module-vars bound-vars really-compile #F
  731.     (lambda (forms module-vars)
  732.       (continue
  733.        `(DYLAN::WHILE (LAMBDA () (DYLAN::NOT ,(car forms)))
  734.               (LAMBDA () ,@(if (null? (cdr forms))
  735.                        (list #F)
  736.                        (cdr forms))))
  737.        module-vars))))
  738.  
  739. (define (compile-UNWIND-PROTECT-form
  740.      forms module-vars bound-vars really-compile
  741.      multiple-values? continue)
  742.   (must-be-list-of-at-least-length forms 1 "UNWIND-PROTECT: bad syntax")
  743.   (really-compile (car forms) module-vars bound-vars multiple-values?
  744.     (lambda (c-protect module-vars)
  745.       (really-compile `(BEGIN ,@(cdr forms))
  746.               module-vars bound-vars #F
  747.     (lambda (c-cleanup module-vars)
  748.       (continue
  749.        `(DYLAN::DYNAMIC-WIND (LAMBDA () 'DONE)
  750.                  (LAMBDA () ,c-protect)
  751.                  (LAMBDA () ,c-cleanup))
  752.        module-vars))))))
  753.  
  754. (define (compile-WHEN-form
  755.      forms module-vars bound-vars really-compile
  756.      multiple-values? continue)
  757.   (must-be-list-of-at-least-length forms 1 "WHEN: bad syntax")
  758.   (compile-forms forms module-vars bound-vars really-compile
  759.          (if (null? (cdr forms)) #F multiple-values?)
  760.     (lambda (forms module-vars)
  761.       (continue
  762.        `(IF ,(car forms)
  763.         (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  764.         #F)
  765.        module-vars))))
  766.  
  767. (define (compile-WHILE-form
  768.      forms module-vars bound-vars really-compile
  769.      multiple-values? continue)
  770.   (must-be-list-of-at-least-length forms 1 "UNTIL: bad syntax")
  771.   (compile-forms forms module-vars bound-vars really-compile
  772.          (if (null? (cdr forms)) #F multiple-values?)
  773.     (lambda (forms module-vars)
  774.       (continue
  775.        `(DYLAN::WHILE (LAMBDA () ,(car forms))
  776.               (LAMBDA () ,@(if (null? (cdr forms))
  777.                        (list #F)
  778.                        (cdr forms))))
  779.        module-vars))))
  780.