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 / callcode.sc next >
Text File  |  1991-10-11  |  14KB  |  389 lines
  1. ;;; Code generator for $call and $lap expressions.
  2. ;;;
  3.  
  4. ;*              Copyright 1989 Digital Equipment Corporation
  5. ;*                         All Rights Reserved
  6. ;*
  7. ;* Permission to use, copy, and modify this software and its documentation is
  8. ;* hereby granted only under the following terms and conditions.  Both the
  9. ;* above copyright notice and this permission notice must appear in all copies
  10. ;* of the software, derivative works or modified versions, and any portions
  11. ;* thereof, and both notices must appear in supporting documentation.
  12. ;*
  13. ;* Users of this software agree to the terms and conditions set forth herein,
  14. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  15. ;* right and license under any changes, enhancements or extensions made to the
  16. ;* core functions of the software, including but not limited to those affording
  17. ;* compatibility with other hardware or software environments, but excluding
  18. ;* applications which incorporate this software.  Users further agree to use
  19. ;* their best efforts to return to Digital any such changes, enhancements or
  20. ;* extensions that they make and inform Digital of noteworthy uses of this
  21. ;* software.  Correspondence should be provided to Digital at:
  22. ;* 
  23. ;*                       Director of Licensing
  24. ;*                       Western Research Laboratory
  25. ;*                       Digital Equipment Corporation
  26. ;*                       100 Hamilton Avenue
  27. ;*                       Palo Alto, California  94301  
  28. ;* 
  29. ;* This software may be distributed (but not offered for sale or transferred
  30. ;* for compensation) to third parties, provided such third parties agree to
  31. ;* abide by the terms and conditions of this notice.  
  32. ;* 
  33. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  34. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  35. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  36. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  37. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  38. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  39. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  40. ;* SOFTWARE.
  41.  
  42. (module callcode)
  43.  
  44. ;;; External and in-line declarations.
  45.  
  46. (include "plist.sch")
  47. (include "expform.sch")
  48. (include "lambdaexp.sch")
  49. (include "miscexp.sch")
  50. (include "gencode.sch")
  51. (include "lap.sch")
  52.  
  53. ;;; ($call tail func arg ...)  ==>  emit code for the call and return it's
  54. ;;;                    result.
  55. ;;;
  56. ;;; The first step in generating code for a call is figuring out the type of
  57. ;;; function being called and the type of call.  This is done by the following
  58. ;;; function which then calls the appropriate function to actually generate
  59. ;;; code for the call.
  60.  
  61. (define ($CALL-GENC loc exp bindings)
  62.     (let* ((func ($call-func exp))
  63.        (tail ($call-tail exp))
  64.        (argl ($call-argl exp))
  65.        (id   (if (symbol? func) (id-lambda func) #f)))
  66.       (cond (($lambda? func)
  67.          (inline-call loc func argl bindings))
  68.         (($lap? func)
  69.          ($lap-genc loc func argl bindings))
  70.         ((and id tail (or (eq? (lambda-generate id) 'inline-tail)
  71.                   (la-exits-lb? tail id)))
  72.          (tail-call loc func argl id bindings))
  73.         ((and id (eq? (lambda-generate id) 'inline))
  74.          (inline-call loc (lambda-$lambda id) argl bindings))
  75.         ((and id (id-type func))
  76.          (known-c-call loc func argl id bindings))
  77.         (id
  78.          (known-call loc func argl id bindings))
  79.         (else
  80.          (unknown-call loc func argl bindings)))))
  81.  
  82. (define (LA-EXITS-LB? ida idb)
  83.     (and ida (or (eq? ida idb) (la-exits-lb? (lambda-exits ida) idb))))
  84.        
  85. ;;; When the function is a lambda expression, or when there is only one actual
  86. ;;; call to an internally defined function, then it may be expanded in-line.
  87. ;;; The lambda expression is effectively treated as LET, with the arguments
  88. ;;; used as the initial values.
  89.  
  90. (define (INLINE-CALL loc exp argl bindings)
  91.     (let* ((id   ($lambda-id exp))
  92.        (req  (lambda-reqvars id))
  93.        (opt  (optional-args id))
  94.        (temp-state (save-lap-temps))
  95.        (varl '())
  96.        (vals '())
  97.        (save-free-display free-display)
  98.  
  99.        ;;; Assign a temp. to the lexically bound var if it does not
  100.        ;;; have a memory location.  Build the varl and vals lists.
  101.  
  102.        (bind (lambda (var)
  103.              (set! varl (cons var varl))
  104.              (set! vals
  105.                    (cons (cond ((id-display var)
  106.                         (when (not (memq var bindings))
  107.                           (reserve-display (list var)
  108.                               bindings)
  109.                           (set! bindings
  110.                             (cons var bindings)))
  111.                         `("DISPLAY" ,(id-display var)))
  112.                        ((not (memq var bindings))
  113.                         (set! bindings (cons var bindings))
  114.                         (set-id-vname! var (use-lap-temp))
  115.                         var)
  116.                        (else var))
  117.                      vals))
  118.              (car vals))))
  119.  
  120.       (cond ((or (and opt (< (length argl) (length req)))
  121.              (and (null? opt) (not (eq? (length argl) (length req)))))
  122.          (report-error "Incorrect number of arguments for lambda"))
  123.         (else
  124.          (for-each
  125.              (lambda (var)
  126.                  (if (and (id-lambda var)
  127.                       (not (eq? (lambda-generate
  128.                             (id-lambda var))
  129.                         'closed-procedure)))
  130.                  (exp-genc 'no-value (car argl) bindings)
  131.                  (exp-genc (bind var) (car argl) bindings))
  132.                  (set! argl (cdr argl)))
  133.              req)
  134.          (if opt
  135.              (listify-optional-args (bind opt) argl bindings))
  136.          (lambda-body-genc loc exp varl vals bindings)))
  137.       (set! free-display save-free-display)
  138.       (restore-lap-temps temp-state)))
  139.  
  140. ;;; Optional arguments are combined into a list by the caller.  This function
  141. ;;; emits the code to evaluate each argument and form them into a list.
  142.  
  143. (define (LISTIFY-OPTIONAL-ARGS var argl bindings)
  144.     (if argl
  145.     (let ((ltemp (use-lap-temp)))
  146.          (let loop ((argl (reverse argl)) (reg "EMPTYLIST"))
  147.           (exp-genc 'tos (car argl) bindings)
  148.           (cond ((cdr argl)
  149.              (emit-lap `(SET ,(vname ltemp) (CONS tos ,reg)))
  150.              (loop (cdr argl) (vname ltemp)))
  151.             (else (emit-lap `(SET ,(vname var) (CONS tos ,reg))))))
  152.          (drop-lap-temp ltemp))
  153.     (emit-lap `(SET ,(vname var) EMPTYLIST))))
  154.  
  155. ;;; When a tail-recursive call can be generated, the following routine is
  156. ;;; called.  Tail-recursion elimination is an example of how computer
  157. ;;; scientists can gain insight by observing nature.  When a cat tires of
  158. ;;; chasing its tail, does it have to "unwind" itself?
  159.  
  160. (define (TAIL-CALL loc func argl id bindings)
  161.     (let ((req  (lambda-reqvars id))
  162.       (opt  (optional-args id)))
  163.      (if (or (and opt (< (length argl) (length req)))
  164.          (and (null? opt) (not (eq? (length argl) (length req)))))
  165.          (report-error "Incorrect number of arguments for" func)
  166.          (let ((temp-state (save-lap-temps)))
  167.           (tail-call-bind req opt argl bindings)
  168.           (emit-lap `(GOTO ,(code-label id)))
  169.           (update-condition-info id)
  170.           (restore-lap-temps temp-state)))))
  171.  
  172. ;;; The arguments to a tail-called function are evaluated and assigned taking
  173. ;;; care to avoid the use of a temporary for the evaluation of the last one.
  174. ;;; Note the special case where a temporary must be allocated when the value
  175. ;;; of the argument is one of the function's variables that is being rebound.
  176. ;;; Also note the special handling for binding a variable which is set!.
  177.  
  178. (define (TAIL-CALL-BIND req opt argl bindings)
  179.     (cond ((and (null? req) (null? opt)))
  180.       ((null? req)
  181.        (listify-optional-args (lookup opt bindings) argl bindings))
  182.       ((and (null? (cdr req)) (null? opt))
  183.        (let ((var (car req)))
  184.         (cond ((id-set! var)
  185.                (exp-genc 'tos (car argl) bindings)
  186.                (emit-lap `(SET ,(let ((x (id-display var)))
  187.                          (if x
  188.                          `("DISPLAY" ,x)
  189.                          (vname var)))
  190.                        tos)))
  191.               (else
  192.               (exp-genc (lookup (car req) bindings) (car argl)
  193.                   bindings)))))
  194.       (else
  195.        (let ((var (car req))
  196.          (val (let ((arg (car argl)))
  197.                (if (or (eq? arg opt) (memq arg (cdr req)))
  198.                    (let ((temp (use-lap-temp)))
  199.                     (exp-genc temp arg bindings)
  200.                     temp)
  201.                    (car (load-argl (list arg) bindings))))))
  202.         (tail-call-bind (cdr req) opt (cdr argl) bindings)
  203.         (let ((displayx (id-display var)))
  204.              (if (id-set! var)
  205.              (emit-lap `(SET ,(if displayx
  206.                           `("DISPLAY" ,displayx)
  207.                           (vname var))
  208.                      ,val))
  209.              (emit-lap `(SET ,(lookup var bindings) ,val))))))))
  210.  
  211. ;;; When the function is a block of lap code, then it will be evaluated here.
  212. ;;; Arguments will be looked up and then the lap code will be emitted with
  213. ;;; appropriate substitutions.
  214.  
  215. (define ($LAP-GENC loc lap argl bindings)
  216.     (let ((alist '())
  217.       (save-temp (save-lap-temps)))
  218.      (do ((vars ($lap-vars lap)           (cdr vars))
  219.           (vals (load-argl argl bindings) (cdr vals)))
  220.          ((or (null? vars) (null? vals))
  221.           (if (or vals vars)
  222.           (report-error
  223.               "Incorrect number of arguments for LAP construct")))
  224.          (set! alist (cons (list (car vars) (car vals)) alist)))
  225.      (let loop ((laps ($lap-body lap)))
  226.           (cond ((cdr laps)
  227.              (emit-lap (subsym (car laps) alist))
  228.              (loop (cdr laps)))
  229.             (else (emit-lap `(SET ,(vname loc)
  230.                       ,(subsym (car laps) alist))))))
  231.      (restore-lap-temps save-temp)))
  232.  
  233. ;;; Arguments are substituted into the lap code by the following function.
  234.  
  235. (define (SUBSYM exp alist)
  236.     (cond ((null? exp) exp)
  237.       ((symbol? exp)
  238.        (let ((old-new (assq exp alist)))
  239.         (if old-new (vname (cadr old-new)) exp)))
  240.       ((pair? exp)
  241.        (cons (subsym (car exp) alist)
  242.          (subsym (cdr exp) alist)))
  243.       (else exp)))
  244.  
  245. ;;; When a known C function is called, the following procedure emits the code
  246. ;;; to call it with converted arguments and then convert the result.
  247.  
  248. (define (KNOWN-C-CALL loc func argl id bindings)
  249.     (let* ((req       (lambda-reqvars id))
  250.        (opt       (lambda-optvars id))
  251.        (reqlen    (length req))
  252.        (save-lap  (save-lap-temps))
  253.        (argl      (load-argl argl bindings)))
  254.       (emit-extern func)
  255.       (cond ((or (and (null? opt) (not (= (length argl) reqlen)))
  256.              (and opt (< (length argl) reqlen)))
  257.          (report-error "Incorrect number of arguments for"
  258.              (id-printname func)))
  259.         (else
  260.          (emit-lap
  261.              `(SET TOS
  262.                (,(cname id)
  263.                 ,@(let loop ((args argl) (types (append req opt)))
  264.                    (if args
  265.                        (cons           
  266.                        (case (car types)
  267.                             ((char)
  268.                           `(TSCP_CHAR ,(car args)))
  269.                          ((int)
  270.                           `(TSCP_INT ,(car args)))
  271.                          ((shortint)
  272.                           `(SHORTINT
  273.                                (TSCP_INT ,(car args))))
  274.                          ((longint)
  275.                           `(LONGINT
  276.                                (TSCP_INT ,(car args))))
  277.                          ((unsigned)
  278.                           `(TSCP_UNSIGNED ,(car args)))
  279.                          ((shortunsigned)
  280.                           `(SHORTUNSIGNED
  281.                                (TSCP_UNSIGNED
  282.                                ,(car args))))
  283.                          ((longunsigned)
  284.                           `(LONGUNSIGNED
  285.                                (TSCP_UNSIGNED
  286.                                ,(car args))))
  287.                          ((pointer)
  288.                           `(TSCP_POINTER ,(car args)))
  289.                          ((float)
  290.                           `(CFLOAT (TSCP_DOUBLE
  291.                                    ,(car args))))
  292.                          ((double)
  293.                           `(TSCP_DOUBLE ,(car args)))
  294.                          (else (car args)))
  295.                        (loop (cdr args)
  296.                          (or (cdr types) types)))
  297.                        '())))))
  298.          (emit-lap
  299.              `(SET ,(vname loc)
  300.                ,(case (or (eq? loc 'no-value) (id-type func))
  301.                   ((#t) 'TOS)
  302.                   ((char) '(CHAR_TSCP TOS))
  303.                   ((int) '(INT_TSCP TOS))
  304.                   ((shortint longint) '(INT_TSCP (INT TOS)))
  305.                   ((unsigned) '(UNSIGNED_TSCP TOS))
  306.                   ((shortunsigned longunsigned)
  307.                    '(UNSIGNED_TSCP (UNSIGNED TOS)))
  308.                   ((pointer) '(POINTER_TSCP TOS))
  309.                   ((float) '(DOUBLE_TSCP (CDOUBLE TOS)))
  310.                   ((double) '(DOUBLE_TSCP TOS))
  311.                   ((void)
  312.                    (report-warning
  313.                        "C procedure does not return a value:"
  314.                        (cname id))
  315.                    (emit-lap '(SET NO-VALUE TOS))
  316.                    'FALSEVALUE)
  317.                   (else '(_TSCP TOS)))))))
  318.       (restore-lap-temps save-lap)))
  319.  
  320. ;;; When a known function is called, the minimal calling sequence necessary
  321. ;;; is generated, and the argument count can be checked at compile time.  Note
  322. ;;; the special case for functions with a variable number of arguments which
  323. ;;; do not have a module name.  This is to allow calls to ULTRIX or C-library
  324. ;;; routines which take a variable number of arguments.
  325.  
  326. (define (KNOWN-CALL loc func argl id bindings)
  327.     (let* ((req       (lambda-reqvars id))
  328.        (opt       (optional-args id))
  329.        (reqlen    (length req))
  330.        (save-lap  (save-lap-temps)))
  331.       (emit-extern func)
  332.       (cond ((or (and (null? opt) (not (= (length argl) reqlen)))
  333.              (and opt (< (length argl) reqlen)))
  334.          (report-error "Incorrect number of arguments for"
  335.              (id-printname func)))
  336.         ((and opt (equal? (id-module func) ""))
  337.          (set! argl (load-argl argl bindings))
  338.          (emit-lap `(SET ,(vname loc) (,(cname id) ,@argl))))
  339.         (else
  340.          (set! req (load-argl (list-head argl reqlen) bindings))
  341.          (if opt
  342.              (listify-optional-args 'tos (list-tail argl reqlen)
  343.              bindings))    
  344.          (emit-lap
  345.              `(SET ,(vname loc)
  346.                (,(cname id)
  347.                 ,@req
  348.                 ,@(if opt '(tos) '())
  349.                 ,@(if (eq? (lambda-generate id) 'closed-procedure)
  350.                   `((PROCEDURE_CLOSURE
  351.                     ,(lookup func bindings)))
  352.                   '()))))))
  353.       (restore-lap-temps save-lap)))
  354.  
  355. ;;; The most general calling sequence is when nothing is known about the
  356. ;;; procedure.  If the procedure takes a fixed number of arguments, then the
  357. ;;; call will be in-line, otherwise, a special form of APPLY will be used
  358. ;;; as the trampoline.
  359.  
  360. (define (UNKNOWN-CALL loc func argl bindings)
  361.     (let* ((save-state (save-lap-temps))
  362.        (proc (use-lap-temp))
  363.        (argtemps (load-argl argl bindings)))
  364.       (exp-genc proc func bindings)
  365.       (emit-lap `(SET ,proc (UNKNOWNCALL ,(vname proc) ,(length argl))))
  366.       (emit-lap `(SET ,(vname loc)
  367.               ((VIA (PROCEDURE_CODE ,(vname proc)))
  368.                ,@argtemps
  369.                (PROCEDURE_CLOSURE ,(vname proc)))))
  370.       (restore-lap-temps save-state)))
  371.  
  372. ;;; Argument lists are evaluated and loaded into temporary variables by the
  373. ;;; following function.  It returns a list of variables which hold the
  374. ;;; values.
  375.  
  376. (define (LOAD-ARGL argl bindings)
  377.     (map (lambda (arg)
  378.          (if (and (symbol? arg)
  379.               (or (var-in-stack arg)
  380.                   (and (var-is-global arg) (not (id-type arg)))
  381.                   (var-is-constant arg)))
  382.              (begin 
  383.                 (emit-extern arg)
  384.                 (lookup arg bindings))
  385.              (let ((temp (use-lap-temp)))
  386.               (exp-genc temp arg bindings)
  387.               temp)))
  388.      argl))
  389.