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 / lap.sc < prev    next >
Text File  |  1991-10-11  |  16KB  |  471 lines
  1. ;;; The functions in this module are used to emit C code.  At the
  2. ;;; current time, the only functions are to collect the code and then print
  3. ;;; it out when each block completes.
  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 lap)
  45.  
  46. ;;; Global code is emitted by calling the following function.  As it consists
  47. ;;; solely of declarations, no peep-hole optimization need be down.
  48.  
  49. (define GLOBAL-LAP-CODE '())
  50.  
  51. (define (EMIT-GLOBAL-LAP code)
  52.     (set! global-lap-code (cons code global-lap-code)))
  53.  
  54. ;;; LAP-CODE is a list of the current generated code.  As items are cons'ed
  55. ;;; onto it, it is in reverse order.
  56.  
  57. (define LAP-CODE '())
  58.  
  59. ;;; CODE is generated by calling EMIT-CODE with a list which consists
  60. ;;; of the operator followed by any operands.  At this point, a small
  61. ;;; amount of peep-hole optimization is done.
  62.  
  63. (define (EMIT-LAP code)
  64.     (let* ((old lap-code)
  65.        (new (peep-lap code)))
  66.       (if (and (log? 'peep) (not (equal? new (cons code old))))
  67.           (begin (format sc-icode "/* ")
  68.              (do ((i (min 1 (- (length old) 1)) (- i 1)))
  69.              ((negative? i))
  70.              (format sc-icode " ~A" (list-ref old i)))
  71.              (format sc-icode " ~A~%  =>" code)
  72.              (do ((i (min 2 (- (length new) 1)) (- i 1)))
  73.              ((negative? i))
  74.              (format sc-icode " ~A" (list-ref new i)))
  75.              (format sc-icode " */~%")))))         
  76.  
  77. (define (PEEP-LAP code)
  78.     (cond ((null? lap-code)
  79.        (set! lap-code (cons code lap-code)))
  80.       ((eq? (car code) 'LABEL)
  81.        (cond ((eq? (caar lap-code) 'LABEL)
  82.           ; L1        =>     L1
  83.           ; L2
  84.           (let ((l1 (cadar lap-code))
  85.             (l2 (cadr code)))
  86.                (set-id-alias! l2 l1)
  87.                (set-id-gotos! (resolve-label l2)
  88.                               (+ (id-gotos (resolve-label l2))
  89.                      (id-gotos l2)))
  90.                (set! code (car lap-code))
  91.                (set! lap-code (cdr lap-code))
  92.                (emit-lap code)))
  93.          ((equal? (car lap-code) (list 'goto (cadr code)))
  94.           ; GOTO L    =>     L
  95.           ; L
  96.           (bump-label-gotos (car lap-code) -1)
  97.           (set! lap-code (cdr lap-code))
  98.           (emit-lap code))
  99.          ((and (eq? (caar lap-code) 'goto) (eq? (caadr lap-code) 'if)
  100.                (eq? (resolve-label (caddr (cadr lap-code)))
  101.                 (resolve-label (cadr code))))
  102.           ; IF TEST GOTO L1   =>  IF NOT TEST GOTO L2
  103.           ; GOTO L2               L1
  104.           ; L1
  105.           (let* ((test (cadadr lap-code))
  106.              (op   (and (pair? test) (car test))))
  107.             (bump-label-gotos (cadr lap-code) -1)
  108.             (set! test
  109.                   (if (and (pair? test) (eq? (car test) 'NOT))
  110.                   (cadr test)
  111.                   `(NOT ,test)))
  112.             (set! lap-code
  113.                   (cons code
  114.                     (cons (list 'if test (cadar lap-code))
  115.                       (cddr lap-code))))))
  116.          (else  (set! lap-code (cons code lap-code)))))
  117.       ((and (eq? (car code) 'SET)
  118.         (or (and (eq? (cadr code) 'no-value)
  119.              (and (not (pair? (caddr code)))
  120.                   (not (eq? (caddr code) 'tos))))
  121.             (eq? (caddr code) 'no-value)
  122.             (equal? (cadr code) (caddr code))))
  123.         ; no-value := x      =>
  124.         ; x := no-value      =>
  125.             ; x := x             =>
  126.          ; Flush Loads or Stores which are "nop's".
  127.        #t)
  128.       ((and lap-code
  129.         (or (eq? (caar lap-code) 'goto)
  130.             (and (eq? (caar lap-code) 'set)
  131.              (eq? (cadar lap-code) 'return)))
  132.         (not (memq (car code) '(LIT INDENT LABEL))))
  133.             ; GOTO L / RETURN        =>   GOTO L / RETURN
  134.         ; << anything but a label or end >>
  135.        #t)
  136.       ((and (eq? (car code) 'goto) (eq? (caar lap-code) 'label)
  137.         (not (eq? (resolve-label (cadr code)) (cadar lap-code))))
  138.             ; L1          =>   GOTO L2   (maybe!)
  139.         ; GOTO L2
  140.        (set-id-alias! (cadar lap-code) (resolve-label (cadr code)))
  141.            (set-id-gotos! (resolve-label (cadr code))
  142.            (+ (id-gotos (resolve-label (cadr code)))
  143.            (id-gotos (cadar lap-code))))
  144.        (set! lap-code (cdr lap-code))
  145.        (emit-lap code))
  146.       (else
  147.        (bump-label-gotos code 1)
  148.        (set! lap-code (cons code lap-code))))
  149.     lap-code)
  150.  
  151. (define (BUMP-LABEL-GOTOS lap incdec)
  152.     (let ((label (case (car lap)
  153.                ((if) (caddr lap))
  154.                ((goto) (cadr lap))
  155.                (else #f))))
  156.      (if label
  157.          (begin (set! label (resolve-label label))
  158.             (set-id-gotos! label (+ (id-gotos label) incdec))))))
  159.  
  160. (define (SAVE-CURRENT-LAP lap)
  161.     (let ((result (list lap-code lap-temps-used lap-temps-free
  162.             lap-max-display)))
  163.      (if lap
  164.          (begin (set! lap-code (list-ref lap 0))
  165.             (set! lap-temps-used (list-ref lap 1))
  166.             (set! lap-temps-free (list-ref lap 2))
  167.             (set! lap-max-display (list-ref lap 3)))
  168.          (begin (set! lap-code '())
  169.             (set! lap-temps-used '())
  170.             (set! lap-temps-free
  171.               '(    X1  X2  X3  X4  X5  X6  X7  X8  X9
  172.                    X10 X11 X12 X13 X14 X15 X16 X17 X18 X19
  173.                    X20 X21 X22 X23 X24 X25 X26 X27 X28 X29
  174.                    X30 X31 X32 X33 X34 X35 X36 X37 X38 X39
  175.                    X40 X41 X42 X43 X44 X45 X46 X47 X48 X49
  176.                    X50 X51 X52 X53 X54 X55 X56 X57 X58 X59
  177.                    X60 X61 X62 X63 X64 X65 X66 X67 X68 X69
  178.                    X70 X71 X72 X73 X74 X75 X76 X77 X78 X79
  179.                    X80 X81 X82 X83 X84 X85 X86 X87 X88 X89
  180.                    X90 X91 X92 X93 X94 X95 X96 X97 X98 X99))
  181.             (set! lap-max-display free-display)))
  182.      result))
  183.  
  184. (define LAP-TEMPS-USED '())
  185.  
  186. (define LAP-TEMPS-FREE '())
  187.  
  188. (define LAP-MAX-DISPLAY 0)
  189.  
  190. (define (USE-LAP-TEMP)
  191.     (let ((temp (car lap-temps-free)))
  192.      (if (not (memq temp lap-temps-used))
  193.          (set! lap-temps-used (cons temp lap-temps-used)))
  194.      (set! lap-temps-free (cdr lap-temps-free))
  195.      temp))
  196.  
  197. (define (DROP-LAP-TEMP temp)
  198.     (set! lap-temps-free (cons temp lap-temps-free)))
  199.  
  200. (define (SAVE-LAP-TEMPS) lap-temps-free)
  201.  
  202. (define (RESTORE-LAP-TEMPS state) (set! lap-temps-free state))
  203.  
  204. (define DONE-LAP-LAP '())
  205.  
  206. (define (DONE-LAP lap)
  207.     (if global-lap-code
  208.     (let ((lap (list global-lap-code '() '() '())))
  209.          (set! global-lap-code '())
  210.          (done-lap lap)))
  211.     (if (log? 'lap)
  212.     (begin (format sc-icode "/* ")
  213.            (pretty-print-$tree (reverse (car lap)) sc-icode)
  214.            (format sc-icode " */~%")))
  215.     (set! done-lap-lap lap)
  216.     (pplap (reverse (car lap)) (cadr lap) (cadddr lap) sc-icode))
  217.  
  218. (define (RESOLVE-LABEL label)
  219.     (let ((new (id-alias label)))
  220.      (if new
  221.          (resolve-label new)
  222.          label)))
  223.  
  224. (define (PPLAP laps temps lap-max-display port)
  225.     (let ((indent "")
  226.       (display-base #f))
  227.      (newline port)
  228.      (set! pplap-tos #f)
  229.      (for-each
  230.          (lambda (lap)
  231.              (case (car lap)
  232.                ((LIT)
  233.                 (display indent port)
  234.                 (for-each
  235.                 (lambda (x)
  236.                     (if (pair? x)
  237.                         (pplap-call x port)
  238.                         (display x port))) (cdr lap))
  239.                 (newline port))
  240.                ((LABEL)
  241.                 (let ((label (resolve-label (cadr lap))))
  242.                  (if (and (eq? label (cadr lap))
  243.                       (not (zero? (id-gotos label))))
  244.                          (format port "~a:~%" label))))
  245.                ((INDENT)
  246.                 (set! indent (make-string (cadr lap) #\space)))
  247.                ((PROC)
  248.                 (display "TSCP  " port)
  249.                 (pplap-call (cdr lap) port)
  250.                 (newline port)
  251.                 (when (cddr lap)
  252.                   (display "        TSCP  " port)
  253.                   (pplap-comma-list (cddr lap) port)
  254.                   (display ";" port)
  255.                   (newline port))) 
  256.                ((LOCALS)
  257.                 (when temps
  258.                   (format port "~aTSCP  " indent)
  259.                   (pplap-comma-list (map vname temps) port)
  260.                   (format port ";~%"))
  261.                 (if (cdr lap)
  262.                 (let ((base (caddr lap)))
  263.                      (let loop ((x base))
  264.                       (when (< x lap-max-display)
  265.                         (format port
  266.                         "~aTSCP  SD~a = DISPLAY( ~a );~%"
  267.                                     indent x x)
  268.                         (loop (+ x 1))))
  269.                      (if (not (= base lap-max-display))
  270.                      (begin (set! display-base base)
  271.                         (format port
  272.                             "~aTSCP  SDVAL;~%"
  273.                             indent)))))
  274.                 (if (or temps display-base) (newline port)))
  275.                ((GOTO)
  276.                 (format port "~agoto ~a;~%" indent
  277.                     (resolve-label (cadr lap))))
  278.                ((IF)
  279.                 (format port "~aif  ( " indent)
  280.                 (pplap-call (cadr lap) port)
  281.                 (if (< (- (write-width port) (write-count port))
  282.                    20)
  283.                 (format port "~%~a   " indent))
  284.                 (format port " )  goto  ~a;~%"
  285.                     (resolve-label (caddr lap))))
  286.                ((SET)
  287.                 (case (cadr lap)
  288.                   ((NO-VALUE)
  289.                    (display indent port)
  290.                    (pplap-call (caddr lap) port)
  291.                    (format port ";~%"))
  292.                   ((TOS)
  293.                    (let ((new-tos (subst-tos (caddr lap))))
  294.                     (if pplap-tos
  295.                             (report-error
  296.                         "PPLAP compiler error"))
  297.                     (set! pplap-tos new-tos)))
  298.                   ((RETURN)
  299.                    (when display-base
  300.                      (unless (equal? (caddr lap) "void")
  301.                           (format port "~aSDVAL = " indent)
  302.                           (pplap-call (caddr lap) port)
  303.                           (format port ";~%"))
  304.                          (let loop ((x display-base))
  305.                           (when (< x lap-max-display)
  306.                             (format port
  307.                             "~aDISPLAY( ~a ) = SD~a;~%"
  308.                                     indent x x)
  309.                             (loop (+ x 1)))))
  310.                    (let ((val (if display-base
  311.                           '("SDVAL")
  312.                           (cddr lap))))
  313.                         (display indent port)
  314.                     (cond ((equal? (caddr lap) "void")
  315.                            (display "return" port))
  316.                           (sc-stack-trace
  317.                                (pplap-call
  318.                            (cons "POPSTACKTRACE" val)
  319.                            port))
  320.                           (else
  321.                            (pplap-call
  322.                            (cons "return" val)
  323.                                port))))
  324.                    (format port ";~%"))
  325.                   (else
  326.                    (display indent port)
  327.                    (pplap-call (cadr lap) port)
  328.                    (display " = " port)
  329.                    (pplap-call (caddr lap) port)
  330.                    (format port ";~%"))))
  331.                (else  (display indent port)
  332.                   (pplap-call lap port)
  333.                   (format port ";~%")))) 
  334.          laps)))
  335.  
  336. (define PPLAP-TOS '())
  337.  
  338. (define (POP-TOS)
  339.     (let ((tos pplap-tos))
  340.      (set! pplap-tos #f)
  341.      (if tos tos (report-error "POP-TOS compiler error"))))
  342.  
  343. (define (SUBST-TOS form)
  344.     (cond ((eq? form 'tos)
  345.        (pop-tos))
  346.       ((pair? form)
  347.        (cons (subst-tos (car form)) (subst-tos (cdr form))))
  348.       (else form)))
  349.  
  350. (define (PPLAP-CALL lap port)
  351.     (let ((limit (- (write-width port) 5)))
  352.      (cond ((pair? lap)
  353.             (cond ((eq? (car lap) 'CSTRING)
  354.                (display #\" port)
  355.                (for-each
  356.                (lambda (c)
  357.                    (cond ((assq c '((#\tab . #\t)
  358.                             (#\newline . #\n)
  359.                             (#\linefeed . #\n)
  360.                             (#\formfeed . #\f)
  361.                             (#\return . #\r)
  362.                             (#\" . #\")
  363.                             (#\\ . #\\)))
  364.                        => (lambda (old.new)
  365.                               (display #\\ port)
  366.                               (display (cdr old.new)
  367.                               port)))
  368.                      ((or (char<? c #\space)
  369.                           (char>? c #\~))
  370.                       (display #\\ port)
  371.                       (display (list->string
  372.                                (char->dl c 8 3))))
  373.                      (else (display c port)))
  374.                    (when (> (write-count port) limit)
  375.                          (display #\\ port)
  376.                          (newline port)))
  377.                (string->list (cadr lap)))
  378.                (display #\" port))
  379.               ((and (memq (car lap) '(TRUE FALSE NOT))
  380.                 (eq? (cadr lap) 'TOS))
  381.                (pplap-call (list (car lap) (pop-tos)) port))
  382.               ((and (eq? (car lap) 'NOT) (pair? (cadr lap)))
  383.                (let* ((op (caadr lap))
  384.                   (operands (cdadr lap))
  385.                   (invert (assq op
  386.                        '((EQ . NEQ)
  387.                          (NEQ . EQ)
  388.                          (TRUE . FALSE)
  389.                          (FALSE . TRUE)
  390.                          (LT . GTE)
  391.                          (GTE . LT)
  392.                          (GT . LTE)
  393.                          (LTE . GT)))))
  394.                  (cond ((eq? op 'NOT)
  395.                     (pplap-call (car operands) port))
  396.                    (invert
  397.                     (pplap-call (cons (cdr invert) operands)
  398.                     port))
  399.                    (else (format port "~a( " (car lap))
  400.                      (pplap-comma-list (cdr lap) port)
  401.                      (display " )" port)))))
  402.               ((and (eq? (car lap) 'TRUE) (pair? (cadr lap))
  403.                 (eq? (caadr lap) 'BOOLEAN))
  404.                (pplap-call (cadadr lap) port))
  405.               ((and (eq? (car lap) 'FALSE) (pair? (cadr lap))
  406.                 (eq? (caadr lap) 'BOOLEAN))
  407.                (pplap-call `(NOT ,(cadadr lap)) port))
  408.               (else (pplap-call (car lap) port)
  409.                     (display "( " port)
  410.                 (pplap-comma-list (cdr lap) port)
  411.                 (display " )" port))))
  412.             ((eq? lap 'TOS)
  413.          (pplap-call (pop-tos) port))
  414.         ((and (symbol? lap) (id-use lap))
  415.          (if (not (eq? (vname lap) lap))
  416.              (report-error "PPLAP looked up a symbol:" lap))
  417.          (display (vname lap) port))
  418.         (else (display lap port)))))
  419.  
  420. (define (PPLAP-COMMA-LIST lap port)
  421.     (let* ((indent (write-count port))
  422.        (nextline (negative? (pplap-size lap
  423.                     (- (write-width port) indent)))))
  424.       (when lap
  425.         (pplap-call (car lap) port)
  426.         (when (cdr lap)
  427.               (display ", " port)
  428.               (when nextline
  429.                 (newline port)
  430.                 (set-write-count! port indent))
  431.               (pplap-comma-list (cdr lap) port)))))
  432.  
  433. (define (PPLAP-SIZE lap left)
  434.     (cond ((negative? left) left)
  435.       ((null? lap) left)
  436.       ((pair? lap)
  437.        (if (eq? (car lap) 'CSTRING)
  438.            (- left (+ (string-length (cadr lap)) 5))
  439.            (pplap-size (cdr lap) (pplap-size (car lap) (- left 4)))))
  440.       ((eq? lap 'TOS)
  441.        (pplap-size pplap-tos left))
  442.       (else (- left
  443.            (string-length (format "~a.."
  444.                       (if (and (symbol? lap) (id-use lap))
  445.                           (vname lap)
  446.                           lap)))))))
  447.  
  448. ;;; Downshift a symbol name.  Leave any other value unchanged.
  449.  
  450. (define (DOWNSHIFT op)
  451.     (if (symbol? op) (string-downcase (symbol->string op)) op))
  452.  
  453. ;;; Initialization for this module is preformed by the following procedure.
  454.  
  455. (define (LOAD-PLIST-LAP)
  456.     (for-each
  457.     (lambda (x)
  458.         (set-id-vname! x x)
  459.         (set-id-use! x '$lexical))
  460.     '(    X1  X2  X3  X4  X5  X6  X7  X8  X9
  461.          X10 X11 X12 X13 X14 X15 X16 X17 X18 X19
  462.          X20 X21 X22 X23 X24 X25 X26 X27 X28 X29
  463.          X30 X31 X32 X33 X34 X35 X36 X37 X38 X39
  464.          X40 X41 X42 X43 X44 X45 X46 X47 X48 X49
  465.          X50 X51 X52 X53 X54 X55 X56 X57 X58 X59
  466.          X60 X61 X62 X63 X64 X65 X66 X67 X68 X69
  467.          X70 X71 X72 X73 X74 X75 X76 X77 X78 X79
  468.          X80 X81 X82 X83 X84 X85 X86 X87 X88 X89
  469.          X90 X91 X92 X93 X94 X95 X96 X97 X98 X99
  470.          TOS NO-VALUE RETURN)))
  471.