home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scsc / gencode.sc < prev    next >
Encoding:
Text File  |  1991-10-11  |  13.9 KB  |  406 lines
  1. ;;; This is when the actual code generation occurs.  It is entered with a
  2. ;;; list of expressions.  Code is not as optimal as it might be, but then
  3. ;;; that's what the C compiler is for.
  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 gencode)
  45.  
  46. ;;; External and in-line declarations.
  47.  
  48. (include "plist.sch")
  49. (include "expform.sch")
  50. (include "lambdaexp.sch")
  51. (include "miscexp.sch")
  52. (include "lap.sch")
  53.  
  54. ;;; Top-level globals.
  55.  
  56. (define CURRENT-CODE-LAMBDA 'top-level)
  57.  
  58. (define CURRENT-DEFINE-STRING '())    ; id which is the string defining the
  59.                     ; current top-level DEFINE.
  60.  
  61. (define INIT-MODULES '())
  62.  
  63. (define FREE-DISPLAY 0)
  64.  
  65. (define MAX-DISPLAY 0)
  66.  
  67. (define EMPTY-CONDITION-INFO '(()) )
  68.  
  69. (define GLOBAL-CONDITION-INFO empty-condition-info)
  70.  
  71. (define ERROR-ID #f)
  72.  
  73. (define $_CAR-ERROR-ID #f)
  74.  
  75. (define $_CDR-ERROR-ID #f)
  76.  
  77. (define (GENERATE-CODE expl)
  78.     (let ((bindings '())
  79.       (initname (if main-program-name
  80.             "main"
  81.             (string-append module-name "__init")))
  82.       (constant-lap '()))
  83.      (set! current-code-lambda 'top-level)
  84.      (set! current-define-name 'top-level)
  85.      (save-current-lap #f)
  86.      (set! max-display 0)
  87.      (set! free-display 0)
  88.      (set! error-id (bound 'error))
  89.      (set! $_car-error-id (bound '$_car-error))
  90.      (set! $_cdr-error-id (bound '$_cdr-error))
  91.      (set! global-lap-code '())
  92.      (emit-global-lap `(LIT "/* SCHEME->C */"))
  93.      (emit-global-lap `(LIT))
  94.      (emit-global-lap `(LIT "#include " #\< ,c-include-file #\>))
  95.          (emit-global-lap '(LIT))
  96.      (set! init-modules '())
  97.      (if main-program-name
  98.          (begin (emit-lap '(LIT "main( argc, argv )"))
  99.             (emit-lap '(LIT "        int argc;  char *argv[];")))
  100.          (emit-lap `(LIT "void  " ,initname "()")))
  101.      (emit-lap '(LIT "{"))
  102.      (emit-lap '(indent 8))
  103.      (emit-lap '(LOCALS DISPLAY 0))
  104.      (emit-lap '(LIT "static int  init = 0;"))
  105.      (emit-lap '(LIT "if  (init)  return;"))
  106.      (emit-lap '(LIT "init = 1;"))
  107.      (if main-program-name
  108.          (emit-lap `(INITHEAP ,heap-size "argc" "argv"
  109.                 ,(cname (id-global main-program-name))))
  110.          (emit-lap `(INITHEAP ,heap-size 0 0 0)))
  111.      (emit-lap '(LIT "init_constants();"))
  112.      (set! constant-lap (emit-constants))
  113.      (done-lap constant-lap)
  114.      (emit-lap
  115.          `(LIT "init_modules( "
  116.            (CSTRING ,(string-append "(" module-name
  117.                  " SCHEME->C COMPILER " scc-version ")"))
  118.            " );"))
  119.      (for-each (lambda (exp) 
  120.              (set! global-condition-info empty-condition-info)
  121.              (exp-genc 'no-value exp bindings))
  122.            expl)
  123.      (if main-program-name
  124.          (let ((name (id-global main-program-name)))
  125.           (emit-global-lap
  126.               `(LIT "void  " ,module-name "__init(){}"))
  127.           (if name
  128.               (emit-lap `(LIT ,(cname name)
  129.                       "( CLARGUMENTS( argc, argv ) );"))
  130.               (report-error "Main procedure is not defined"))
  131.           (emit-lap '(LIT "SCHEMEEXIT();")))
  132.          (emit-lap '(SET RETURN "void")))
  133.      (emit-lap '(indent 0))
  134.      (emit-lap '(LIT "}"))
  135.      (if (not (= 0 free-display))
  136.          (report-error "Compiler error - display index is not 0"))
  137.      (generate-init_modules)
  138.      (done-lap (save-current-lap '()))))
  139.  
  140. ;;; Code for each expression is generated by the following function.  It
  141. ;;; returns the code which evaluates to the expression.
  142.  
  143. (define (EXP-GENC loc exp bindings)        
  144.     (cond ((symbol? exp)         (symbol-genc loc exp bindings))
  145.       ((eq? (car exp) '$call)   ($call-genc loc exp bindings))
  146.       ((eq? (car exp) '$set)    ($set-genc loc exp bindings))
  147.       ((eq? (car exp) '$lambda) ($lambda-genc loc exp bindings))
  148.       ((eq? (car exp) '$if)        ($if-genc loc exp bindings))
  149.       ((eq? (car exp) '$define) ($define-genc loc exp bindings))
  150.       ((eq? (car exp) '$lap)    (report-error "Illegal use of LAP"))
  151.       (else
  152.        (report-error "GENERATE-CODE compiler error" exp))))       
  153.  
  154. ;;; Labels are needed during the code generation and are constructed by the
  155. ;;; following function.  ID-BOUNDREFS is used to keep track of the number of
  156. ;;; references.
  157.  
  158. (define (MAKE-LABEL) (newv 'l 'use 'label 'gotos 0))
  159.  
  160. ;;; Code labels are automatically constructed for all lambda expressions by
  161. ;;; the following function.  Labels that are not used are removed during
  162. ;;; peep-hole optimization of the lap code.
  163.  
  164. (define (CODE-LABEL id)
  165.     (let ((label (lambda-code-label id)))
  166.      (if (not label)
  167.          (begin (set! label (make-label))
  168.             (set-lambda-code-label! id label)))
  169.      label))
  170.  
  171. ;;; Global names are sometimes needed in the C-code and are emitted by the
  172. ;;; following function.
  173.  
  174. (define (MAKE-C-GLOBAL)
  175.     (newv 'temp 'use 'temporary))
  176.       
  177. ;;; The optional argument (if any) of a function is returned by the following
  178. ;;; function.
  179.  
  180. (define (OPTIONAL-ARGS id)
  181.     (if (lambda-optvars id)
  182.         (car (lambda-optvars id))
  183.     '()))
  184.  
  185. ;;; Variables are "looked-up" in the current bindings by the following
  186. ;;; function.  It returns the code the access the value bound to the
  187. ;;; variable.
  188.  
  189. (define (LOOKUP var bindings)
  190.     (let ((offset 0)
  191.       (code '()))
  192.      (cond ((var-is-constant var)
  193.         (vname var))
  194.            ((var-is-global var)
  195.         (emit-extern var)
  196.         (or (vname var)
  197.             (and (id-type var) (cname var))
  198.             (report-error "SYMBOL does not have a value cell"
  199.             (id-printname var))))
  200.            ((var-in-stack var)
  201.         (let ((displayx (id-display var)))
  202.              (cond ((id-set! var)
  203.                 `(PAIR_CAR ,(if displayx
  204.                         `("DISPLAY" ,displayx)
  205.                         (vname var))))
  206.                (displayx `("DISPLAY" ,displayx))
  207.                (else (vname var)))))
  208.            ((var-is-top-level var)
  209.         `(SYMBOL_VALUE ,(vname var)))
  210.            (else (report-error "Variable is not bound" (vname var))))))
  211.  
  212. (define (VAR-IN-STACK var)
  213.     (eq? (id-use var) 'lexical))
  214.  
  215. (define (VAR-IS-GLOBAL var)
  216.     (eq? (id-use var) 'global))
  217.  
  218. (define (EMIT-EXTERN var)
  219.     (if (id-lambda var)
  220.     (set! var (lambda-name (id-lambda var))))
  221.     (when (not (id-external var))
  222.       (set-id-external! var #t)
  223.       (cond ((and (id-lambda var)
  224.               (assq (id-type var)
  225.                 '((void . EXTERNVOIDP)
  226.                   (pointer . EXTERNPOINTERP)
  227.                   (tscp . EXTERNTSCPP)
  228.                   (char . EXTERNCHARP)
  229.                   (int . EXTERNINTP)
  230.                   (shortint .  EXTERNSHORTINTP)
  231.                   (longint . EXTERNLONGINTP)
  232.                   (unsigned . EXTERNUNSIGNEDP)
  233.                   (shortunsigned . EXTERNSHORTUNSIGNEDP)
  234.                   (longunsigned . EXTERNLONGUNSIGNEDP)
  235.                   (float . EXTERNFLOATP)
  236.                   (double . EXTERNDOUBLEP))))
  237.          => (lambda (type)
  238.                 (emit-global-lap `(,(cdr type) ,(cname var)))))
  239.         ((assq (id-type var)
  240.                '((pointer . EXTERNPOINTER)
  241.              (tscp . EXTERNTSCP)
  242.              (char . EXTERNCHAR)
  243.              (int . EXTERNINT)
  244.              (shortint .  EXTERNSHORTINT)
  245.              (longint . EXTERNLONGINT)
  246.              (unsigned . EXTERNUNSIGNED)
  247.              (shortunsigned . EXTERNSHORTUNSIGNED)
  248.              (longunsigned . EXTERNLONGUNSIGNED)
  249.              (float . EXTERNFLOAT)
  250.              (double . EXTERNDOUBLE)))
  251.          => (lambda (type)
  252.                 (emit-global-lap `(,(cdr type) ,(vname var)))))
  253.         (else
  254.          (if (id-lambda var)
  255.              (emit-global-lap `(EXTERNTSCPP ,(cname var))))
  256.          (if (var-is-global var)
  257.              (let ((vmodule (id-module var)))
  258.                (if (vname var)
  259.                        (emit-global-lap `(EXTERNTSCP ,(vname var))))
  260.               (if (and (not (equal? module-name vmodule))
  261.                    (not (member vmodule '("" "sc")))
  262.                    (not (member vmodule init-modules)))
  263.                   (set! init-modules
  264.                     (cons (id-module var) init-modules)))))))))
  265.  
  266. (define (VAR-IS-CONSTANT var) (eq? (id-use var) 'constant))
  267.  
  268. (define (VAR-IS-TOP-LEVEL var) (eq? (id-use var) 'top-level))
  269.  
  270. ;;; When all code has been emitted, this function is called to emit the
  271. ;;; procedure "init_modules" which calls the initialization code for all
  272. ;;; modules used by this program.
  273.  
  274. (define (GENERATE-INIT_MODULES)
  275.     (let ((save-lap (save-current-lap '())))
  276.      (emit-lap '(LIT "static void  init_modules( compiler_version )"))
  277.      (emit-lap '(LIT "        char *compiler_version;"))
  278.      (emit-lap '(LIT"{"))
  279.      (emit-lap '(indent 8))
  280.      (for-each
  281.          (lambda (with-module)
  282.              (emit-lap
  283.              `(LIT ,(string-append  with-module "__init();"))))
  284.          (append init-modules with-modules))
  285.      (emit-lap `(MAXDISPLAY ,max-display))
  286.      (emit-lap '(indent 0))
  287.      (emit-lap `(LIT "}"))
  288.      (done-lap (save-current-lap save-lap))))
  289.  
  290. ;;; All storage and initialization for constants is emitted at the start of
  291. ;;; the module's initialization function.  Since vectors and lists are
  292. ;;; constructed from the heap, they must be registered with the run-time
  293. ;;; system.
  294.  
  295. (define CONSTANT-SYMBOLS '())
  296.  
  297. (define CONSTANT-SYMBOL-PORT '())
  298.  
  299. (define (EMIT-CONSTANTS)
  300.     (let ((save-lap (save-current-lap '())))
  301.      (set! constant-symbols '())
  302.      (set! constant-symbol-port (open-output-string))
  303.      (emit-lap '(LIT "static void  init_constants()"))
  304.      (emit-lap '(LIT "{"))
  305.      (emit-lap '(INDENT 8))
  306.      (emit-lap '(LOCALS))
  307.      (for-each
  308.          (lambda (const-var)
  309.              (let ((var (cadr const-var))
  310.                (const (car const-var))
  311.                (temps (save-lap-temps)))
  312.               (emit-constant var const)
  313.               (if (and (not (string? const)) (not (number? const))
  314.                    (not (char? const)))
  315.                   (emit-lap `(CONSTANTEXP (ADR ,(vname var)))))
  316.               (restore-lap-temps temps)))
  317.          quote-constants)
  318.      (emit-lap '(INDENT 0))
  319.      (emit-lap '(LIT "}"))
  320.      (save-current-lap save-lap)))
  321.  
  322. (define (EMIT-CONSTANT var const)
  323.     (cond ((fixed? const)
  324.        (display "_TSCP( " constant-symbol-port)
  325.        (if (or (> const 2) (< const -2))
  326.            (begin (write (+ (* 4 (quotient const 10))
  327.                 (quotient (* 4 (remainder const 10)) 10))
  328.                  constant-symbol-port)
  329.               (write (abs (remainder (* 4 (remainder const 10)) 10))
  330.                  constant-symbol-port))
  331.            (write (remainder (* 4 (remainder const 10)) 10)
  332.               constant-symbol-port))
  333.        (display " )" constant-symbol-port)
  334.        (set-id-vname! var (get-output-string constant-symbol-port)))
  335.       ((float? const)
  336.        (let ((temp (make-c-global)))
  337.         (emit-global-lap `(DEFFLOAT ,(vname temp) ,const))
  338.         (emit-global-lap `(DEFSTATICTSCP2 ,(vname var)
  339.                       ,(vname temp)))))
  340.       ((char? const)
  341.        (display "_TSCP( " constant-symbol-port)
  342.        (write (+ (* (char->integer const) 256) 18)
  343.           constant-symbol-port)
  344.        (display " )" constant-symbol-port)
  345.        (set-id-vname! var (get-output-string constant-symbol-port)))
  346.       ((string? const)
  347.        (let ((temp (make-c-global)))
  348.         (emit-global-lap `(DEFSTRING ,(vname temp) (CSTRING ,const)
  349.                       ,(string-length const)))
  350.         (emit-global-lap `(DEFSTATICTSCP2 ,(vname var)
  351.                       ,(vname temp)))))
  352.       ((symbol? const)
  353.        (let ((temp (make-c-global)))
  354.         (emit-global-lap `(DEFSTRING ,(vname temp)
  355.                       (CSTRING ,(symbol->string const))
  356.                       ,(string-length
  357.                            (symbol->string const))))
  358.         (emit-global-lap `(DEFSTATICTSCP ,(vname var)))
  359.         (emit-lap `(SET ,(vname var)
  360.                  (STRINGTOSYMBOL (U_TX (ADR ,(vname temp))))))
  361.         (set! constant-symbols
  362.               (cons (list const var) constant-symbols))))
  363.       ((pair? const)
  364.        (if (eq? (id-use var) 'constant)
  365.            (emit-global-lap  `(DEFSTATICTSCP ,(vname var))))
  366.        (emit-constant-list (vname var) const))
  367.       ((vector? const)
  368.        (emit-constant var (vector->list const))
  369.        (emit-lap `(SET ,(vname var) (LISTTOVECTOR ,(vname var)))))
  370.       (else (report-error "EMIT-CONSTANT compile error:" const))))
  371.  
  372. (define (EMIT-CONSTANT-LIST varname const)
  373.     (cond ((pair? const)
  374.        (emit-constant-list varname (cdr const))
  375.        (emit-lap `(SET ,varname
  376.                (CONS ,(emit-constant-element (car const))
  377.                  ,varname))))
  378.       (else
  379.            (emit-lap `(SET ,varname
  380.                    ,(emit-constant-element const))))))
  381.  
  382. (define (EMIT-CONSTANT-ELEMENT const)
  383.     (cond ((eq? const #t) "TRUEVALUE" )
  384.       ((eq? const '()) "EMPTYLIST" )
  385.       ((eq? const #f) "FALSEVALUE")
  386.       ((equal? const "") "EMPTYSTRING")
  387.       ((equal? const '#()) "EMPTYVECTOR")
  388.       ((or (fixed? const) (char? const))
  389.        (emit-constant 'emit-constant-kludge const))
  390.       ((pair? const)
  391.        (let ((temp (use-lap-temp)))
  392.         (emit-constant-list (vname temp) const)
  393.         (drop-lap-temp temp)
  394.         (id-vname temp)))
  395.       ((vector? const)
  396.        (let ((temp (use-lap-temp)))
  397.         (emit-constant temp const)
  398.         (drop-lap-temp temp)
  399.         (id-vname temp)))       
  400.       ((and (symbol? const) (assq const constant-symbols))
  401.        => (lambda (symbol.const) (vname (cadr symbol.const))))
  402.       (else
  403.        (let ((temp (make-c-global)))
  404.         (emit-constant temp const)
  405.         (id-vname temp)))))
  406.