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 / misccode.sc < prev    next >
Text File  |  1991-10-11  |  12KB  |  337 lines
  1. ;;; Code generator for symbols and $set, $if, and $define 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 misccode)
  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. ;;; identifier
  54. ;;;
  55. ;;; Load it's value into the location.
  56.  
  57. (define (SYMBOL-GENC loc exp bindings)
  58.     (let ((var (lookup exp bindings))
  59.       (c-type (and (eq? (id-use exp) 'global) (id-type exp))))
  60.      (cond ((eq? loc 'no-value)
  61.         #f)
  62.            (c-type
  63.         (emit-lap
  64.             `(SET ,(vname loc)
  65.               ,(case c-type
  66.                  ((char) `(CHAR_TSCP ,var))
  67.                  ((int) `(INT_TSCP ,var))
  68.                  ((shortint longint) `(INT_TSCP (INT ,var)))
  69.                  ((unsigned) `(UNSIGNED_TSCP ,var))
  70.                  ((shortunsigned longunsigned)
  71.                   `(UNSIGNED_TSCP (UNSIGNED ,var)))
  72.                  ((pointer) `(POINTER_TSCP ,var))
  73.                  ((tscp) var)
  74.                  ((float) `(DOUBLE_TSCP (CDOUBLE ,var)))
  75.                  ((double) `(DOUBLE_TSCP ,var))
  76.                  (else (report-error
  77.                        "Cannot load value of"
  78.                        (id-printname exp)))))))
  79.            (else (emit-lap `(SET ,(vname loc) ,var))))))
  80.  
  81. ;;; ($define var exp)
  82. ;;;
  83. ;;; Emit code to declare the global variable, evaluate its initial value,
  84. ;;; and inform the run-time system of its existence.
  85.             
  86. (define ($DEFINE-GENC loc exp bindings)
  87.     (let* ((name  ($define-id exp))
  88.        (body  ($define-exp exp))
  89.        (temp  (make-c-global))
  90.        (string-name (symbol->string (id-printname name))))
  91.       (set! current-define-name (id-printname name))
  92.       (emit-global-lap `(DEFTSCP ,(vname name)))
  93.       (if (not (or (eq? top-level-symbols #t)
  94.                (memq (id-printname name) top-level-symbols)))
  95.           (set! string-name
  96.             (string-append module-name-upcase "_" string-name)))
  97.       (emit-global-lap `(DEFSTRING ,(vname temp)
  98.                 (CSTRING ,string-name)
  99.                 ,(string-length string-name)))
  100.       (set! current-define-string temp)
  101.       (exp-genc 'tos body bindings)
  102.       (set-id-external! name #t)
  103.       (emit-lap `(INITIALIZEVAR (U_TX (ADR ,(vname temp)))
  104.              (ADR ,(vname name)) tos))
  105.       (set! current-define-name 'top-level)))
  106.  
  107. ;;; ($set var exp)
  108. ;;;
  109. ;;; Emit code for expression and store it in var.  Note the special case
  110. ;;; for procedures.
  111.  
  112. (define ($SET-GENC loc exp bindings)
  113.     (let* ((var ($set-id exp))
  114.        (set (if (var-in-stack var)
  115.             'SETGEN
  116.             (if (var-is-top-level var)
  117.             'SETGENTL
  118.             'SET)))
  119.        (c-type (and (eq? (id-use var) 'global) (id-type var))))
  120.       (cond ((and (id-lambda var)
  121.               (not (eq? (lambda-generate (id-lambda var))
  122.                 'closed-procedure)))
  123.          (exp-genc 'no-value ($set-exp exp) bindings))
  124.         (c-type
  125.          (let ((temp (if (eq? loc 'no-value) 'tos (use-lap-temp))))
  126.               (exp-genc temp ($set-exp exp) bindings)
  127.               (emit-lap `(SET tos ,(vname temp)))
  128.               (emit-lap
  129.               `(SET ,(lookup var bindings)
  130.                 ,(case c-type
  131.                    ((char) '(TSCP_CHAR tos))
  132.                    ((int) '(TSCP_INT tos))
  133.                    ((tscp) 'tos)
  134.                    ((shortint) '(SHORTINT (TSCP_INT tos)))
  135.                    ((longint) '(LONGINT (TSCP_INT tos)))
  136.                    ((unsigned) '(TSCP_UNSIGNED tos))
  137.                    ((shortunsigned)
  138.                     '(SHORTUNSIGNED (TSCP_UNSIGNED tos)))
  139.                    ((longunsigned)
  140.                     '(LONGUNSIGNED (TSCP_UNSIGNED tos)))
  141.                    ((pointer) '(TSCP_POINTER tos))
  142.                    ((float) '(CFLOAT (TSCP_DOUBLE tos)))
  143.                    ((double) '(TSCP_DOUBLE tos)))))
  144.               (unless (eq? temp 'tos)
  145.                   (emit-lap `(SET ,(vname loc) ,(vname temp)))
  146.                   (drop-lap-temp temp))))
  147.         (else (let ((temp (if (eq? set 'setgen) (use-lap-temp) 'tos)))
  148.                (exp-genc temp ($set-exp exp) bindings)
  149.                (if (eq? loc 'no-value)
  150.                    (emit-lap `(,SET ,(lookup var bindings) ,temp))
  151.                    (emit-lap
  152.                    `(SET ,(vname loc)
  153.                      (,SET ,(lookup var bindings) ,temp))))
  154.                (unless (eq? temp 'tos) (drop-lap-temp temp)))))))
  155.  
  156. ;;; ($if test true false)
  157. ;;;
  158. ;;; Emit code for $if expression.  If the test condition has been performed
  159. ;;; before, then optimization can be done by taking the one leg that is
  160. ;;; known to be true and ignoring the other one that is known to be false.
  161.  
  162. (define ($IF-GENC loc exp bindings)
  163.   (let ((test ($if-test exp))
  164.     (true ($if-true exp))
  165.     (false ($if-false exp)))
  166.     (if (and ($call? test)
  167.          ($lap? ($call-func test))
  168.          (not (args-set!? ($call-argl test))))
  169.     (begin 
  170.       (cond (($call-tested-true-before? test)
  171.          (exp-genc loc true bindings))
  172.         (($call-tested-false-before? test)
  173.          (exp-genc loc false bindings))
  174.         (else ($if-genc-no-optimize loc exp bindings test))))
  175.     ($if-genc-no-optimize loc exp bindings #f))))
  176.  
  177. ;;; Generate code for evaluating the test and then branching appropriately.
  178. ;;; The branch condition will be reversed when the true leg is returning a
  179. ;;; variable value.
  180.  
  181. (define ($IF-GENC-NO-OPTIMIZE loc exp bindings add-test)
  182.     (let* ((l1 (make-label))
  183.        (l2 (make-label))
  184.        (test ($if-test exp))
  185.        (true ($if-true exp))
  186.        (false ($if-false exp))
  187.        (t/f-reversed #f)
  188.        (tleg-condition '(()))
  189.        (fleg-condition '(()))
  190.        (save-condition global-condition-info)
  191.        (temp (if (eq? loc 'tos) (use-lap-temp) loc)))
  192.       (exp-genc 'tos test bindings)
  193.       (cond ((and (symbol? true) (memq loc '(return no-value)))
  194.          (emit-lap `(IF (TRUE tos) ,l1))
  195.          (set! false true)
  196.          (set! true ($if-false exp))
  197.          (set! t/f-reversed #t))
  198.         (else (emit-lap `(IF (FALSE tos) ,l1))))
  199.       (if add-test
  200.           (add-condition add-test (not t/f-reversed)))
  201.       (exp-genc temp true bindings)
  202.       (set! tleg-condition global-condition-info)
  203.       (set! global-condition-info save-condition)
  204.       (if add-test
  205.           (add-condition add-test t/f-reversed))
  206.       (if (or (not (eq? loc 'no-value)) (not (symbol? false)))
  207.           (begin (if (not (eq? loc 'return)) (emit-lap `(GOTO ,l2)))
  208.              (emit-lap `(LABEL ,l1))
  209.              (exp-genc temp false bindings)
  210.              (if (not (eq? loc 'return)) (emit-lap `(LABEL ,l2))))
  211.           (emit-lap `(LABEL ,l1)))
  212.       (when (eq? loc 'tos)
  213.         (emit-lap `(SET tos ,(vname temp)))
  214.         (drop-lap-temp temp))
  215.       (set! fleg-condition global-condition-info)
  216.       (set! global-condition-info save-condition)
  217.       (cond ((if-leg-has-no-return? true)
  218.          (combine-with-global-condition-info fleg-condition))
  219.         ((if-leg-has-no-return? false)
  220.          (combine-with-global-condition-info tleg-condition))
  221.         (else
  222.          (combine-with-global-condition-info 
  223.           (intersect2 tleg-condition fleg-condition))))))
  224.  
  225. ;; The following are operations that pertain to code optimization by 
  226. ;; elimination of unnecessary $if test conditions that have been tested 
  227. ;; for already.
  228.  
  229. (define (CONDITION-INFO-TRUE-LIST x) (car x))
  230.  
  231. (define (CONDITION-INFO-FALSE-LIST x) (cdr x))
  232.  
  233. (define (STORE-CONDITION-INFO id)
  234.   (put id 'condition-info global-condition-info))
  235.  
  236. (define (RETRIEVE-CONDITION-INFO id)
  237.   (let ((stored-info (get id 'condition-info)))
  238.        (if stored-info
  239.        stored-info
  240.            empty-condition-info)))
  241.  
  242. (define (UPDATE-CONDITION-INFO id)
  243.   (let ((stored-info (get id 'condition-info)))
  244.     (if (null? stored-info)
  245.     (put id 'condition-info global-condition-info)
  246.     (put id 'condition-info 
  247.          (intersect2 stored-info global-condition-info)))))
  248.  
  249. (define (COMBINE-WITH-GLOBAL-CONDITION-INFO  info . info-list)
  250.   (if (null? info-list)
  251.       (set! global-condition-info (combine2 info global-condition-info))
  252.       (combine-with-global-condition-info (combine2 info (car info-list)) 
  253.                       (cdr info-list))))
  254.  
  255. (define (COMBINE2 info1 info2)
  256.   (cons (list-combination (condition-info-true-list info1)
  257.               (condition-info-true-list info2))
  258.     (list-combination (condition-info-false-list info1)
  259.               (condition-info-false-list info2))))
  260.  
  261. (define (LIST-COMBINATION lst1 lst2)
  262.   (if (null? lst2)
  263.       lst1
  264.       (list-combination (append `(,(car lst2))
  265.                 (remove (car lst2) lst1))
  266.             (cdr lst2))))
  267.  
  268. (define (INTERSECT-WITH-GLOBAL-CONDITION-INFO  info . info-list)
  269.   (if (null? info-list)
  270.       (set! global-condition-info (intersect2 info global-condition-info))
  271.       (intersect-with-global-condition-info (intersect2 info (car info-list))
  272.                         (cdr info-list))))
  273.  
  274. (define (INTERSECT2 info1 info2)
  275.   (cons (list-intersection (condition-info-true-list info1)
  276.                (condition-info-true-list info2))
  277.     (list-intersection (condition-info-false-list info1)
  278.                (condition-info-false-list info2))))
  279.  
  280. (define (LIST-INTERSECTION lst1 lst2)
  281.   (if (null? lst1)
  282.       '()
  283.       (if (member (car lst1) lst2)
  284.       (append `(,(car lst1)) (list-intersection (cdr lst1) lst2))
  285.       (list-intersection (cdr lst1) lst2))))
  286.  
  287. (define (STORED-CONDITIONS-INTERSECTION lid-list)
  288.   (define (iter info info-list)
  289.     (if (null? info-list)
  290.     info
  291.     (iter (intersect2 info (car info-list)) (cdr info-list))))
  292.   (let ((stored-info-list (remove '() 
  293.                (map (lambda (lid) (retrieve-condition-info lid))
  294.                 lid-list))))
  295.     (if (null? stored-info-list)
  296.     empty-condition-info
  297.     (iter (car stored-info-list) (cdr stored-info-list)))))
  298.  
  299. (define ($CALL-TESTED-TRUE-BEFORE? test)
  300.   (member test (condition-info-true-list global-condition-info)))
  301.  
  302. (define ($CALL-TESTED-FALSE-BEFORE? test)
  303.   (member test (condition-info-false-list global-condition-info)))
  304.  
  305. (define (ADD-CONDITION test t/f-flag)
  306.   (if t/f-flag 
  307.       ; add true condition
  308.       (set! global-condition-info
  309.         (cons (append `(,test) 
  310.               (remove test 
  311.                   (condition-info-true-list 
  312.                    global-condition-info)))
  313.                (condition-info-false-list global-condition-info)))
  314.       ; otherwise add false condition
  315.       (set! global-condition-info
  316.         (cons  (condition-info-true-list global-condition-info)
  317.                    (append `(,test) 
  318.               (remove test 
  319.                   (condition-info-false-list 
  320.                    global-condition-info)))))))
  321.  
  322. (define (ARGS-SET!? argl)
  323.   (if (null? argl)
  324.       #f
  325.       (let ((first-arg (car argl))
  326.         (rest-args (cdr argl)))
  327.        (if (symbol? first-arg)
  328.            (or (not (or (eq? (id-use first-arg) 'LEXICAL)
  329.                 (eq? (id-use first-arg) 'CONSTANT)))
  330.            (id-set! first-arg)
  331.            (args-set!? rest-args))
  332.            #t))))
  333.  
  334. (define (IF-LEG-HAS-NO-RETURN? leg)
  335.   (and ($call? leg) 
  336.        (member ($call-func leg) `(,error-id ,$_car-error-id ,$_cdr-error-id))))
  337.