home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / MINIBOOT.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  13.2 KB  |  376 lines
  1. ; MINIBOOT.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Minimal Bootstrap Driver                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21. ;* This routine contains compiler-specific code which should be used    *
  22. ;* when compiling the compiler itself. It is generally loaded by the    *
  23. ;* file "COMPILE.ALL" which handles compilation of the compiler and    *
  24. ;* runtime routines.                            *
  25. ;* The file contains compiler-type definitions and macro definitions    *
  26. ;* which must be included when compiling the compiler files.        *
  27. ;************************************************************************
  28. (begin
  29. ;************************************************************************
  30. ;* Define aliases for the major parts of the compiler            *
  31. ;************************************************************************
  32.   (alias pme pcs-macro-expand)
  33.   (alias psimp pcs-simplify)
  34.   (alias pca pcs-closure-analysis)
  35.   (alias pmr pcs-make-readable)
  36.   (alias pcg pcs-gencode)
  37.   (alias ppeep pcs-postgen)
  38.   (alias pal pcs-princode)
  39.   (alias pasm pcs-assembler)
  40. ;************************************************************************
  41. ;* Initialize compile-time variable definitions                *
  42. ;************************************************************************
  43.   (set! pcs-local-var-count 0)
  44.   (set! pcs-verbose-flag #T)
  45.   (set! pcs-permit-peep-1 #T)
  46.   (set! pcs-permit-peep-2 #T)
  47.   (set! pcs-error-flag #F)
  48.   (set! pcs-binary-output #F)
  49. ;************************************************************************
  50. ;* Set up variables to hold compiler-intermediate data and timing info    *
  51. ;************************************************************************
  52.   (define pme= '())
  53.   (define psimp= '())
  54.   (define pca= '())
  55.   (define pcg= '())
  56.   (define ppeep= '())
  57.   (define pasm= '())
  58.   (define problem)
  59.   (define t-0)
  60.   (define t-pme)
  61.   (define t-psimp)
  62.   (define t-pca)
  63.   (define t-pcg)
  64.   (define t-ppeep)
  65.   (define t-pasm)
  66. )
  67.  
  68. ;************************************************************************
  69. ;*             "Type definitions"                *
  70. ;*                                    *
  71. ;*    The following macros are used by the compiler itself and must    *
  72. ;* be defined when compiling the compiler. By keeping them here, the    *
  73. ;* macro definitions will not be around in the object files of the    *
  74. ;* compiler                                *
  75. ;************************************************************************
  76. (macro pcs-make-id                    ; PCS-MAKE-ID
  77.   (lambda (form)
  78.     (let ((name (cadr form)))
  79.       `(begin
  80.      (set! pcs-local-var-count (+ pcs-local-var-count 1))
  81.      (list '#!TOKEN
  82.            (cons ,name
  83.              pcs-local-var-count)
  84.            '() '() '())))))
  85.  
  86. ;************************************************************************
  87. ;* (#!TOKEN (original-name . unique-number) funargsees? freeref?    *
  88. ;*        set!? . init)                        *
  89. ;************************************************************************
  90. (begin
  91.   (syntax (id-name id) (caadr id))
  92.   (syntax (id-number id) (cdadr id))
  93.   (syntax (id-funargsees? id) (car (cddr id)))
  94.   (syntax (id-freeref? id) (car (cdddr id)))
  95.   (syntax (id-set!? id) (cadr (cdddr id)))
  96.   (syntax (id-init id) (cddr (cdddr id)))
  97.  
  98.   (syntax (id-rtv? id)
  99.       (or (id-set!? id)
  100.           (null? (id-init id))
  101.           (lambda-closed? (id-init id))))
  102.  
  103.   (syntax (id-heap? id)
  104.       (and (id-funargsees? id)
  105.            (id-freeref? id)
  106.            (id-rtv? id)))
  107.  
  108.   (syntax (set-id-funargsees? id val) (set-car! (cddr id) val))
  109.   (syntax (set-id-freeref? id val) (set-car! (cdddr id) val))
  110.   (syntax (set-id-set!? id val) (set-car! (cdr (cdddr id)) val))
  111.   (syntax (set-id-init id val) (set-cdr! (cdr (cdddr id)) val))
  112. )
  113.  
  114. ;************************************************************************
  115. ;* (lambda bvl body . (nargs label . closed))                *
  116. ;************************************************************************
  117. (begin
  118.   (syntax (lambda-bvl x) (car (cdr x)))
  119.   (syntax (lambda-body x) (car (cddr x)))
  120.   (syntax (lambda-body-list x) (cddr x))
  121.   (syntax (lambda-nargs x) (car (cdddr x)))
  122.   (syntax (lambda-label x) (car (cdr (cdddr x))))
  123.   (syntax (lambda-debug x) (car (cddr (cdddr x))))
  124.   (syntax (lambda-closed? x) (car (cdddr (cdddr x))))
  125.  
  126.   (syntax (set-lambda-body x val) (set-car! (cddr x) val))
  127.   (syntax (set-lambda-nargs x val) (set-car! (cdddr x) val))
  128.   (syntax (set-lambda-label x val) (set-car! (cdr (cdddr x)) val))
  129.   (syntax (set-lambda-debug x val) (set-car! (cddr (cdddr x)) val))
  130.   (syntax (set-lambda-closed? x val) (set-car! (cdddr (cdddr x)) val))
  131.  
  132.   (macro pcs-extend-lambda
  133.     (lambda (form)
  134.       `(let ((x ,(cadr form)))
  135.      (set-cdr! (cdddr x)        ; X = ('lambda bvl body nargs)
  136.            (list '()        ; label
  137.              '()        ; debug info
  138.              '()))        ; closed?
  139.      x)))
  140. )
  141.  
  142. ;************************************************************************
  143. ;* (letrec pairs body)                            *
  144. ;************************************************************************
  145. (begin
  146.   (syntax (letrec-pairs x) (car (cdr x)))
  147.   (syntax (letrec-body x) (car (cddr x)))
  148.   (syntax (letrec-body-list x) (cddr x))
  149.   (syntax (set-letrec-body x val) (set-car! (cddr x) val))
  150. )
  151.  
  152. ;************************************************************************
  153. ;* (if pred then else)                            *
  154. ;************************************************************************
  155. (begin
  156.   (syntax (if-pred x) (car (cdr x)))
  157.   (syntax (if-then x) (car (cddr x)))
  158.   (syntax (if-else x) (car (cdddr x)))
  159.   (syntax (set-if-pred x val) (set-car! (cdr x) val))
  160.   (syntax (set-if-then x val) (set-car! (cddr x) val))
  161.   (syntax (set-if-else x val) (set-car! (cdddr x) val))
  162. )
  163.     
  164. ;************************************************************************
  165. ;* (set! id exp)                            *
  166. ;************************************************************************
  167. (begin
  168.   (syntax (set!-id x) (car (cdr x)))
  169.   (syntax (set!-exp x) (car (cddr x)))
  170.   (syntax (set-set!-id x val) (set-car! (cdr x) val))
  171.   (syntax (set-set!-exp x val) (set-car! (cddr x) val))
  172. )
  173.  
  174. ;************************************************************************
  175. (define pcs-make-readable                ; PCS-MAKE-READABLE
  176.   (lambda (x)
  177.     (letrec
  178.       ((pmr-exp    (lambda (x)
  179.           (if (atom? x)
  180.               x
  181.               (case (car x)
  182.             (quote x)
  183.             (#!TOKEN (pmr-id x))
  184.             (lambda (pmr-lambda x))
  185.             (letrec (pmr-letrec x))
  186.             (else (mapcar pmr-exp x))))))
  187.        (pmr-id (lambda (x) (cadr x)))
  188.        (pmr-full-id (lambda (x)
  189.               `(#!TOKEN (,(id-name x) . ,(id-number x))
  190.                 (funargsees?= ,(id-funargsees? x))
  191.                 (freeref?= ,(id-freeref? x))
  192.                 (set!?= ,(id-set!? x))
  193.                 (init= ,(if (id-init x) 'lambda '())))))
  194.        (pmr-lambda (lambda (x)
  195.              `(lambda
  196.             ,(mapcar pmr-full-id (lambda-bvl x))
  197.             ,(pmr-exp (lambda-body x))
  198.             (label= ,(lambda-label x))
  199.             (closed?= ,(lambda-closed? x)))))
  200.        (pmr-letrec (lambda (x)
  201.              `(letrec
  202.             ,(pmr-pairs (letrec-pairs x) '())
  203.             ,(pmr-exp (letrec-body x)))))
  204.        (pmr-pairs (lambda (old new)
  205.             (if (null? old)
  206.             (%reverse! new)
  207.             (pmr-pairs (cdr old)
  208.                    (cons (list (pmr-full-id (caar old))
  209.                            (pmr-exp (cadar old)))
  210.                      new)))))
  211.        )
  212.       (pmr-exp x))))
  213.  
  214. ;************************************************************************
  215. ;* Routine to compile a form, setting timing info and intermediate    *
  216. ;* (between compiler phases) data.                    *
  217. ;************************************************************************
  218. (define pcs
  219.   (lambda (exp)
  220.     (begin
  221.       (set! pme= '())
  222.       (set! psimp= '())
  223.       (set! pca= '())
  224.       (set! pcg= '())
  225.       (set! pasm= '())
  226.       (set! pcs-local-var-count 0)
  227.       (set! problem exp)
  228.       (set! pcs-error-flag #F)
  229.       (set! t-0 (car (ptime)))
  230.       (set! pme= (pme exp ))
  231.       (set! t-pme (car (ptime)))
  232.       (if pcs-error-flag
  233.       (error "[Compilation terminated because of errors]")
  234.       (begin
  235.         (set! psimp= (psimp pme=))
  236.         (set! t-psimp (car (ptime)))
  237.         (pca psimp=)
  238.         (set! t-pca (car (ptime)))
  239.         (set! pcg= (pcg psimp=))
  240.         (set! t-pcg (car (ptime)))
  241.         (set! ppeep= (ppeep pcg=))
  242.         (set! t-ppeep (car (ptime)))
  243.         (set! pasm= (pasm ppeep=))
  244.         (set! t-pasm (car (ptime)))
  245.         ))
  246.       `(Times- Total= ,(- t-pasm t-0)
  247.            pme= ,(- t-pme t-0)
  248.            psimp= ,(- t-psimp t-pme)
  249.            pca= ,(- t-pca t-psimp)
  250.            pcg= ,(- t-pcg t-pca)
  251.            ppeep= ,(- t-ppeep t-pcg)
  252.            pasm= ,(- t-pasm t-ppeep))
  253.       )))
  254.  
  255. ;************************************************************************
  256. ;* Compiles a given expression without executing the result        *
  257. ;************************************************************************
  258. (define pcs-compile
  259.   (lambda (exp)
  260.     (set! pcs-verbose-flag #F)
  261.     (set! pcs-binary-output #T)
  262.     (set! pcs-local-var-count 0)
  263.     (set! pcs-error-flag #F)
  264.     (let ((t1 (pme exp)))
  265.       (if pcs-error-flag
  266.       (error "[Compilation terminated because of errors.]")
  267.       (let ((t2 (psimp t1)))
  268.         (pca t2)
  269.         (pasm (ppeep (pcg t2))))))))
  270.  
  271. ;************************************************************************
  272. ;* Set up compile-time aliases. When encountered in a source file,    *
  273. ;* anything assigned via compile-time-alias will be defined as        *
  274. ;* an alias, but will not be written to the object file.        *
  275. ;* See pcs-compile-file in this file !!!                *
  276. ;************************************************************************
  277. (alias compile-time-alias alias)
  278.  
  279. ;************************************************************************
  280. ;* Compiles a given file without executing (unless form is a macro,    *
  281. ;* alias, syntax, or define-integrable) the result.            *
  282. ;* Also report compilation info.                    *
  283. ;************************************************************************
  284. (define pcs-compile-file
  285.   (lambda (filename1 filename2)
  286.     (if (or (not (string? filename1))
  287.         (not (string? filename2))
  288.         (equal? filename1 filename2))
  289.     (error "PCS-COMPILE-FILE arguments must be distinct file names"
  290.            filename1
  291.            filename2)
  292.     (fluid-let ((input-port (open-input-file filename1)))
  293.       (let* ((read (if (string-ci=? (cadddr (filename-split filename1)) ".sw")
  294.                read-sw read))
  295.          (o-port (open-binary-output-file filename2)))
  296.         (begin (princ "#!fast-load 4.0 MINIBOOT (" o-port)
  297.            (princ filename1 o-port)
  298.            (princ ")" o-port)
  299.            (princ #\return o-port)
  300.            (princ #\newline o-port))
  301.         (letrec
  302.           ((loop
  303.          (lambda (form)
  304.            (if (eof-object? form)
  305.                (begin (close-input-port (fluid input-port))
  306.                   (close-output-port o-port)
  307.                   'OK)
  308.                (begin (compile-to-file form)
  309.                   (set! form '())        ; for GC
  310.                   (loop (read))))))
  311.            (compile-to-file
  312.          (lambda (form)
  313.            (let* ((cform (pcs-compile form))
  314.               (nconstants (cadr cform))
  315.               (nbytes (caddr cform))
  316.               (name?? (car (cadddr cform))))
  317.              (if (pair? form)
  318.              (if (eq? (car form) 'COMPILE-TIME-ALIAS)
  319.                  (%execute cform)
  320.                  ;else    
  321.                  (begin
  322.                    (when (and (pair? form)
  323.                       (memq (car form)
  324.                         '(MACRO SYNTAX ALIAS 
  325.                            DEFINE-INTEGRABLE)))
  326.                      (%execute cform))
  327.                    (writeln " " name?? ": ("
  328.                     nconstants "," nbytes ")")
  329.                    (fluid-let ((output-port o-port))
  330.                  (fast-save cform)))))))))
  331.           (loop (read))))))))
  332.  
  333. ;************************************************************************
  334. ;* Compile object code to file. The code generated by ppeep        *
  335. ;* (the peephole optimizer is written to the specified file).        *
  336. ;************************************************************************
  337. (define %compile-file
  338.   (lambda (filename1 filename2)
  339.     (if (or (not (string? filename1))
  340.         (not (string? filename2))
  341.         (equal? filename1 filename2))
  342.     (error "%COMPILE-FILE arguments must be distinct file names"
  343.            filename1
  344.            filename2)
  345.     (fluid-let ((input-port (open-input-file filename1)))
  346.       (let* ((read (if (string-ci=? (cadddr (filename-split filename1)) ".sw")
  347.                read-sw read))
  348.          (o-port (open-binary-output-file filename2)))
  349.         (letrec
  350.           ((loop
  351.          (lambda (form)
  352.            (if (eof-object? form)
  353.                (begin (close-input-port (fluid input-port))
  354.                   (close-output-port o-port)
  355.                   'OK)
  356.                (begin (compile-to-file form)
  357.                   (set! form '())        ; for GC
  358.                   (loop (read))))))
  359.            (compile-to-file
  360.          (lambda (form)
  361.            (let ((t1 (pme form)))
  362.              (if pcs-error-flag
  363.              (writeln "[Compilation terminated because of errors.]")
  364.              (let ((t2 (psimp t1)))
  365.                (pca t2)
  366.                (set! ppeep= (ppeep (pcg t2))))))
  367.            (fluid-let ((output-port o-port))
  368.              (set-line-length! 74)
  369.              (newline)
  370.              (pp form)
  371.              (newline)
  372.              (pcs-princode ppeep=)
  373.              (newline)))))
  374.           (loop (read))))))))
  375.  
  376.