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 / main.sc < prev    next >
Text File  |  1991-10-11  |  11KB  |  352 lines
  1. ;;; This file is the "main" program for the Scheme->C Scheme compiler.  It
  2. ;;; defines the implementation dependent information, a configuration
  3. ;;; function, and the "main" function which interpretes the command line
  4. ;;; arguments and drives the compiler.
  5. ;;;
  6.  
  7. ;*              Copyright 1989 Digital Equipment Corporation
  8. ;*                         All Rights Reserved
  9. ;*
  10. ;* Permission to use, copy, and modify this software and its documentation is
  11. ;* hereby granted only under the following terms and conditions.  Both the
  12. ;* above copyright notice and this permission notice must appear in all copies
  13. ;* of the software, derivative works or modified versions, and any portions
  14. ;* thereof, and both notices must appear in supporting documentation.
  15. ;*
  16. ;* Users of this software agree to the terms and conditions set forth herein,
  17. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  18. ;* right and license under any changes, enhancements or extensions made to the
  19. ;* core functions of the software, including but not limited to those affording
  20. ;* compatibility with other hardware or software environments, but excluding
  21. ;* applications which incorporate this software.  Users further agree to use
  22. ;* their best efforts to return to Digital any such changes, enhancements or
  23. ;* extensions that they make and inform Digital of noteworthy uses of this
  24. ;* software.  Correspondence should be provided to Digital at:
  25. ;* 
  26. ;*                       Director of Licensing
  27. ;*                       Western Research Laboratory
  28. ;*                       Digital Equipment Corporation
  29. ;*                       100 Hamilton Avenue
  30. ;*                       Palo Alto, California  94301  
  31. ;* 
  32. ;* This software may be distributed (but not offered for sale or transferred
  33. ;* for compensation) to third parties, provided such third parties agree to
  34. ;* abide by the terms and conditions of this notice.  
  35. ;* 
  36. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  37. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  38. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  39. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  40. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  41. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  42. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  43. ;* SOFTWARE.
  44.  
  45. (module MAIN
  46.     (main configure)
  47.     (with callcode
  48.           closeana
  49.       compile
  50.       expform
  51.       gencode
  52.       lambdacode
  53.       lambdaexp
  54.       lap
  55.       macros
  56.       misccode
  57.       miscexp
  58.       plist
  59.       readtext
  60.       transform))
  61.  
  62. (define-c-external (system pointer) int "system")
  63.  
  64. (define-c-external (rename pointer pointer) int "rename")
  65.  
  66. (define-c-external (unlink pointer) int "unlink")
  67.  
  68. (define-c-external (getpid) int "getpid")
  69.  
  70. (define SCC-VERSION "28sep90jfb")
  71.                 ; Compiler version string.
  72.  
  73. (define FORCE-LD-OF-REP read-eval-print)
  74.                 ; Assure that read-eval-print is available
  75.                 ; for compiler debugging.
  76.  
  77. (define SC-TO-C.c "SC-TO-C~s.c")    ; Temp C source file name.
  78.  
  79. (define SC-TO-C.o "SC-TO-C~s.o")    ; Temp object file name.
  80.  
  81. ;;; The following top-level variables define the implementation dependent
  82. ;;; information:
  83.  
  84. (define PREDEF-DEFAULT "include:sc/predef.sc")
  85.                     ; File holding the declarations for predefined
  86.                 ; functions.
  87.  
  88. (define C-INCLUDE-FILE "objects.h")
  89.                 ; #include file for the predefined functions.
  90.  
  91. (define C-INCLUDE-DIR "include:sc")
  92.                     ; directory containing #include file for
  93.                 ; predefined functions.
  94.  
  95. (define SC-LIBRARY "lib:sc.lib")
  96.                 ; Scheme->C library file.
  97.  
  98. (define SC-LIBRARY_P "")
  99.                 ; Scheme->C profiled library file.
  100.  
  101. (define SC-PROCESSOR "Amiga")    ; Processor type.
  102.  
  103. ;;; The compiler is "configured" and the heap image is saved by the following
  104. ;;; function.  It will set the previously defined variables to the values
  105. ;;; entered on the command-line and then write a file in the current directory
  106. ;;; with the name <scc.heap> which is the saved heap image for the Scheme->C
  107. ;;; compiler.
  108.  
  109. (define (CONFIGURE clargs)
  110.     (initialize-compile)
  111.     (scc clargs))
  112.  
  113. ;;; When the compiler is invoked directly from the shell, the following
  114. ;;; function is invoked to control compilation.  It will interprete the flags,
  115. ;;; invoke the compiler and then exit.  Any compilation errors or Scheme errors
  116. ;;; will cause the process to abnormally terminate.
  117. ;;;
  118. ;;; The command format is:
  119. ;;;
  120. ;;; scc [ flags ] files...
  121. ;;;
  122. ;;; where the flags are:
  123. ;;;
  124. ;;;    -cc        C compiler
  125. ;;;
  126. ;;;    -C        compile the named Scheme programs and leave the
  127. ;;;            resulting C code in .c files.
  128. ;;;
  129. ;;;    -f flag value   set a compile time constant.  Equivilant to
  130. ;;;            (define-constant flag value).
  131. ;;;
  132. ;;;    -i        produce a Scheme interpreter as the output file.
  133. ;;;
  134. ;;;    -I directory    directory prefix to use for searching for #include
  135. ;;;            files.
  136. ;;;
  137. ;;;    -m module    specifies a module name which must be initialized
  138. ;;;            by the interpreter (see -I) as the source was
  139. ;;;            previously compiled.
  140. ;;;
  141. ;;;    -Ob        optimize C code by omitting bounds checks.
  142. ;;;
  143. ;;;    -Og        optimize C code by omitting stack trace-back code.
  144. ;;;
  145. ;;;    -On        optimize C code by assuming that all numbers are
  146. ;;;            fixed point.
  147. ;;;
  148. ;;;    -Ot        optimize C code by omitting type checks.
  149. ;;; 
  150. ;;;    -pg        compile for gprof profiling.
  151. ;;;
  152. ;;;    -log        log the default compiler events
  153. ;;;
  154. ;;;    -source        specific events to log.
  155. ;;;    -macro
  156. ;;;    -expand
  157. ;;;    -closed
  158. ;;;    -transform
  159. ;;;    -lambda
  160. ;;;    -tree
  161. ;;;    -lap
  162. ;;;    -peep
  163. ;;;
  164. ;;; All other flags will be passed to the C compiler unchanged.  Following
  165. ;;; the flags come source and object files which are to be compiled:
  166. ;;;
  167. ;;;    name.sc        Scheme source file which is to be compiled to
  168. ;;;            to name.c.
  169. ;;;
  170. ;;; All other files are passed to the C compiler unchanged.
  171.  
  172. (define MODULE-NAMES '())
  173.  
  174. (define INCLUDE-DIRS '(""))
  175.  
  176. (define (SCC clargs)
  177.     (let ((flags '())
  178.       (interpreter #f)
  179.       (library `(,sc-library))
  180.       (strace #t)
  181.       (c-only #f)
  182.       (c-flags '())
  183.       (log '())
  184.       (cc "lc"))
  185.      
  186.      ;;; 1. Pick up the command line arguments.
  187.      
  188.      (set! sc-to-c.c (format sc-to-c.c (getpid)))
  189.      (set! sc-to-c.o (format sc-to-c.o (getpid)))
  190.      (let loop ((args (cdr clargs)))
  191.           (if args
  192.           (let ((arg (car args)))
  193.                (cond ((and (equal? arg "-f") (cdr args) (cddr args))
  194.                   (set! flags
  195.                     (cons (string-append
  196.                           "(define-constant "
  197.                           (cadr args)
  198.                           " "
  199.                           (caddr args)
  200.                           ")") flags))
  201.                   (loop (cdddr args)))
  202.                  ((equal? arg "-i")
  203.                   (set! interpreter #t)
  204.                   (loop (cdr args)))
  205.                  ((and (equal? arg "-I") (cdr args))
  206.                   (set! include-dirs
  207.                     (append include-dirs
  208.                         (list (string-append (cadr args)
  209.                               "/"))))
  210.                   (loop (cddr args)))
  211.                  ((and (equal? arg "-m") (cdr args))
  212.                   (set! module-names
  213.                     (cons (cadr args) module-names))
  214.                   (loop (cddr args)))
  215.                  ((equal? arg "-log")
  216.                   (set! log sc-log-default)
  217.                   (loop (cdr args)))
  218.                  ((assoc arg '(("-source" . source)
  219.                        ("-macro" . macro)
  220.                        ("-expand" . expand)
  221.                        ("-closed" . closed)
  222.                        ("-transform" . transform)
  223.                        ("-lambda" . lambda)
  224.                        ("-tree" . tree)
  225.                        ("-lap" . lap)
  226.                        ("-peep" . peep)))
  227.                   =>
  228.                   (lambda (flag)
  229.                       (set! log (cons (cdr flag) log))
  230.                       (loop (cdr args))))
  231.                  ((equal? arg "-Ot")
  232.                   (set! flags
  233.                     (cons "(define-constant *type-check* #f)"
  234.                       flags))
  235.                   (loop (cdr args)))
  236.                  ((equal? arg "-Ob")
  237.                   (set! flags
  238.                     (cons "(define-constant *bounds-check* #f)"
  239.                       flags))
  240.                   (loop (cdr args)))
  241.                  ((equal? arg "-Og")
  242.                   (set! strace #f)
  243.                   (loop (cdr args)))
  244.                  ((equal? arg "-On")
  245.                   (set! flags
  246.                     (cons "(define-constant *fixed-only* #t)"
  247.                       flags))
  248.                   (loop (cdr args)))
  249. ;;                 ((equal? arg "-pg")
  250. ;;                  (set! library `(,sc-library_p))
  251. ;;                  (set! c-flags (cons arg c-flags))
  252. ;;                  (loop (cdr args)))
  253.                  ((equal? arg "-C")
  254.                   (set! c-only #t)
  255.                   (loop (cdr args)))
  256.                  ((and (equal? arg "-cc") (cdr args))
  257.                   (set! cc (cadr args))
  258.                   (loop (cddr args)))
  259.                  (else (set! c-flags
  260.                      (cons (do-c-flag arg flags log strace
  261.                            interpreter)
  262.                            c-flags))
  263.                    (loop (cdr args)))))))
  264.      
  265.      ;;; 2. If -C option was specified, then we're done here.
  266.      
  267.      (if c-only (exit))
  268.      
  269.      ;;; 3. If the -i option was specified, build the main program.
  270.      
  271.      (set! reset
  272.            (let ((prev-reset reset))
  273.             (lambda ()
  274.                 (unlink sc-to-c.c)
  275.                 (unlink sc-to-c.o)
  276.                     (prev-reset))))     
  277.      (if interpreter
  278.          (let ((fh (open-output-file sc-to-c.c)))
  279.           (format fh "#include \"~a/~a\"~%" c-include-dir
  280.               c-include-file)
  281.           (format fh "extern TSCP screp_read_2deval_2dprint();~%")
  282.           (format fh "main( argc, argv )~%{~%")
  283.           (format fh
  284.           "   INITHEAP( 0, argc, argv, screp_read_2deval_2dprint );~%")
  285.           (map (lambda (m) (format fh "   ~a__init();~%" m))
  286.                (cons "screp" module-names))
  287.           (format fh
  288.          "   screp_read_2deval_2dprint( sc_clarguments( argc, argv ) );~%")
  289.           (format fh "   SCHEMEEXIT();~%")
  290.           (format fh "}~%")
  291.           (close-output-port fh)
  292.           (set! c-flags (cons sc-to-c.c c-flags))))
  293.      
  294.      ;;; 4. Flags processed and all .sc -> .c compiles done.   Invoke the
  295.      ;;; C compiler to do the rest.
  296.  
  297.      (unless (eq? 0
  298.               (system (apply string-append
  299.                          `(,cc " -csu -f8 -b0 -r0 -C -d" ,sc-processor
  300.                        " -i" ,c-include-dir
  301.                        " -Lm"
  302.                            ,@(map (lambda (x)
  303.                               (string-append "+" x))
  304.                           library)
  305.                            ,@(map (lambda (x)
  306.                               (string-append " " x))
  307.                                   (append (reverse c-flags)))))))
  308.          (reset))
  309.      (unlink sc-to-c.c)
  310.      (unlink sc-to-c.o)))
  311.        
  312. ;;; Command line arguments which are not recognized as Scheme->C
  313. ;;; flags are processed by the following function which will 
  314. ;;; return the argument to pass to the C compiler.
  315.        
  316. (define (DO-C-FLAG arg flags log strace interpreter)
  317.     (let* ((len (string-length arg))
  318.        (root (substring arg 0 (max 0 (- len 3))))
  319.        (root.c (string-append root ".c")))
  320.       (cond ((and (> len 3)
  321.               (string=?
  322.               (substring arg (- len 3) len)
  323.               ".sc"))
  324.          ;;; Compile an .sc file to a .c file.
  325.          (format #t "~a:~%" arg)
  326.          (initialize-compile)
  327.          (for-each
  328.              (lambda (flag)
  329.                  (do-define-constant
  330.                  (read (open-input-string
  331.                        flag))))
  332.              flags)
  333.          (set! sc-include-dirs include-dirs)
  334.          (set! sc-input
  335.                (list (open-input-file arg)))
  336.          (set! sc-source-name arg)
  337.          (set! sc-icode
  338.                (open-output-file sc-to-c.c))
  339.          (set! sc-error stderr-port)
  340.          (set! sc-log log)
  341.          (set! sc-stack-trace strace)
  342.          (set! sc-interpreter interpreter)
  343.          (docompile)
  344.          (if (not (zero? sc-error-cnt)) (reset))
  345.          (set! module-names (cons module-name module-names))
  346.          (close-sc-files)
  347.          (unlink root.c)
  348.          (rename sc-to-c.c root.c)
  349.          root.c)
  350.         ;;; Pass argument to C.
  351.         (else arg))))
  352.