;;; This file is the "main" program for the Scheme->C Scheme compiler. It ;;; defines the implementation dependent information, a configuration ;;; function, and the "main" function which interpretes the command line ;;; arguments and drives the compiler. ;;; ;* Copyright 1989 Digital Equipment Corporation ;* All Rights Reserved ;* ;* Permission to use, copy, and modify this software and its documentation is ;* hereby granted only under the following terms and conditions. Both the ;* above copyright notice and this permission notice must appear in all copies ;* of the software, derivative works or modified versions, and any portions ;* thereof, and both notices must appear in supporting documentation. ;* ;* Users of this software agree to the terms and conditions set forth herein, ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free ;* right and license under any changes, enhancements or extensions made to the ;* core functions of the software, including but not limited to those affording ;* compatibility with other hardware or software environments, but excluding ;* applications which incorporate this software. Users further agree to use ;* their best efforts to return to Digital any such changes, enhancements or ;* extensions that they make and inform Digital of noteworthy uses of this ;* software. Correspondence should be provided to Digital at: ;* ;* Director of Licensing ;* Western Research Laboratory ;* Digital Equipment Corporation ;* 100 Hamilton Avenue ;* Palo Alto, California 94301 ;* ;* This software may be distributed (but not offered for sale or transferred ;* for compensation) to third parties, provided such third parties agree to ;* abide by the terms and conditions of this notice. ;* ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;* SOFTWARE. (module MAIN (main configure) (with callcode closeana compile expform gencode lambdacode lambdaexp lap macros misccode miscexp plist readtext transform)) (define-c-external (system pointer) int "system") (define-c-external (rename pointer pointer) int "rename") (define-c-external (unlink pointer) int "unlink") (define-c-external (getpid) int "getpid") (define SCC-VERSION "28sep90jfb") ; Compiler version string. (define FORCE-LD-OF-REP read-eval-print) ; Assure that read-eval-print is available ; for compiler debugging. (define SC-TO-C.c "SC-TO-C~s.c") ; Temp C source file name. (define SC-TO-C.o "SC-TO-C~s.o") ; Temp object file name. ;;; The following top-level variables define the implementation dependent ;;; information: (define PREDEF-DEFAULT "include:sc/predef.sc") ; File holding the declarations for predefined ; functions. (define C-INCLUDE-FILE "objects.h") ; #include file for the predefined functions. (define C-INCLUDE-DIR "include:sc") ; directory containing #include file for ; predefined functions. (define SC-LIBRARY "lib:sc.lib") ; Scheme->C library file. (define SC-LIBRARY_P "") ; Scheme->C profiled library file. (define SC-PROCESSOR "Amiga") ; Processor type. ;;; The compiler is "configured" and the heap image is saved by the following ;;; function. It will set the previously defined variables to the values ;;; entered on the command-line and then write a file in the current directory ;;; with the name which is the saved heap image for the Scheme->C ;;; compiler. (define (CONFIGURE clargs) (initialize-compile) (scc clargs)) ;;; When the compiler is invoked directly from the shell, the following ;;; function is invoked to control compilation. It will interprete the flags, ;;; invoke the compiler and then exit. Any compilation errors or Scheme errors ;;; will cause the process to abnormally terminate. ;;; ;;; The command format is: ;;; ;;; scc [ flags ] files... ;;; ;;; where the flags are: ;;; ;;; -cc C compiler ;;; ;;; -C compile the named Scheme programs and leave the ;;; resulting C code in .c files. ;;; ;;; -f flag value set a compile time constant. Equivilant to ;;; (define-constant flag value). ;;; ;;; -i produce a Scheme interpreter as the output file. ;;; ;;; -I directory directory prefix to use for searching for #include ;;; files. ;;; ;;; -m module specifies a module name which must be initialized ;;; by the interpreter (see -I) as the source was ;;; previously compiled. ;;; ;;; -Ob optimize C code by omitting bounds checks. ;;; ;;; -Og optimize C code by omitting stack trace-back code. ;;; ;;; -On optimize C code by assuming that all numbers are ;;; fixed point. ;;; ;;; -Ot optimize C code by omitting type checks. ;;; ;;; -pg compile for gprof profiling. ;;; ;;; -log log the default compiler events ;;; ;;; -source specific events to log. ;;; -macro ;;; -expand ;;; -closed ;;; -transform ;;; -lambda ;;; -tree ;;; -lap ;;; -peep ;;; ;;; All other flags will be passed to the C compiler unchanged. Following ;;; the flags come source and object files which are to be compiled: ;;; ;;; name.sc Scheme source file which is to be compiled to ;;; to name.c. ;;; ;;; All other files are passed to the C compiler unchanged. (define MODULE-NAMES '()) (define INCLUDE-DIRS '("")) (define (SCC clargs) (let ((flags '()) (interpreter #f) (library `(,sc-library)) (strace #t) (c-only #f) (c-flags '()) (log '()) (cc "lc")) ;;; 1. Pick up the command line arguments. (set! sc-to-c.c (format sc-to-c.c (getpid))) (set! sc-to-c.o (format sc-to-c.o (getpid))) (let loop ((args (cdr clargs))) (if args (let ((arg (car args))) (cond ((and (equal? arg "-f") (cdr args) (cddr args)) (set! flags (cons (string-append "(define-constant " (cadr args) " " (caddr args) ")") flags)) (loop (cdddr args))) ((equal? arg "-i") (set! interpreter #t) (loop (cdr args))) ((and (equal? arg "-I") (cdr args)) (set! include-dirs (append include-dirs (list (string-append (cadr args) "/")))) (loop (cddr args))) ((and (equal? arg "-m") (cdr args)) (set! module-names (cons (cadr args) module-names)) (loop (cddr args))) ((equal? arg "-log") (set! log sc-log-default) (loop (cdr args))) ((assoc arg '(("-source" . source) ("-macro" . macro) ("-expand" . expand) ("-closed" . closed) ("-transform" . transform) ("-lambda" . lambda) ("-tree" . tree) ("-lap" . lap) ("-peep" . peep))) => (lambda (flag) (set! log (cons (cdr flag) log)) (loop (cdr args)))) ((equal? arg "-Ot") (set! flags (cons "(define-constant *type-check* #f)" flags)) (loop (cdr args))) ((equal? arg "-Ob") (set! flags (cons "(define-constant *bounds-check* #f)" flags)) (loop (cdr args))) ((equal? arg "-Og") (set! strace #f) (loop (cdr args))) ((equal? arg "-On") (set! flags (cons "(define-constant *fixed-only* #t)" flags)) (loop (cdr args))) ;; ((equal? arg "-pg") ;; (set! library `(,sc-library_p)) ;; (set! c-flags (cons arg c-flags)) ;; (loop (cdr args))) ((equal? arg "-C") (set! c-only #t) (loop (cdr args))) ((and (equal? arg "-cc") (cdr args)) (set! cc (cadr args)) (loop (cddr args))) (else (set! c-flags (cons (do-c-flag arg flags log strace interpreter) c-flags)) (loop (cdr args))))))) ;;; 2. If -C option was specified, then we're done here. (if c-only (exit)) ;;; 3. If the -i option was specified, build the main program. (set! reset (let ((prev-reset reset)) (lambda () (unlink sc-to-c.c) (unlink sc-to-c.o) (prev-reset)))) (if interpreter (let ((fh (open-output-file sc-to-c.c))) (format fh "#include \"~a/~a\"~%" c-include-dir c-include-file) (format fh "extern TSCP screp_read_2deval_2dprint();~%") (format fh "main( argc, argv )~%{~%") (format fh " INITHEAP( 0, argc, argv, screp_read_2deval_2dprint );~%") (map (lambda (m) (format fh " ~a__init();~%" m)) (cons "screp" module-names)) (format fh " screp_read_2deval_2dprint( sc_clarguments( argc, argv ) );~%") (format fh " SCHEMEEXIT();~%") (format fh "}~%") (close-output-port fh) (set! c-flags (cons sc-to-c.c c-flags)))) ;;; 4. Flags processed and all .sc -> .c compiles done. Invoke the ;;; C compiler to do the rest. (unless (eq? 0 (system (apply string-append `(,cc " -csu -f8 -b0 -r0 -C -d" ,sc-processor " -i" ,c-include-dir " -Lm" ,@(map (lambda (x) (string-append "+" x)) library) ,@(map (lambda (x) (string-append " " x)) (append (reverse c-flags))))))) (reset)) (unlink sc-to-c.c) (unlink sc-to-c.o))) ;;; Command line arguments which are not recognized as Scheme->C ;;; flags are processed by the following function which will ;;; return the argument to pass to the C compiler. (define (DO-C-FLAG arg flags log strace interpreter) (let* ((len (string-length arg)) (root (substring arg 0 (max 0 (- len 3)))) (root.c (string-append root ".c"))) (cond ((and (> len 3) (string=? (substring arg (- len 3) len) ".sc")) ;;; Compile an .sc file to a .c file. (format #t "~a:~%" arg) (initialize-compile) (for-each (lambda (flag) (do-define-constant (read (open-input-string flag)))) flags) (set! sc-include-dirs include-dirs) (set! sc-input (list (open-input-file arg))) (set! sc-source-name arg) (set! sc-icode (open-output-file sc-to-c.c)) (set! sc-error stderr-port) (set! sc-log log) (set! sc-stack-trace strace) (set! sc-interpreter interpreter) (docompile) (if (not (zero? sc-error-cnt)) (reset)) (set! module-names (cons module-name module-names)) (close-sc-files) (unlink root.c) (rename sc-to-c.c root.c) root.c) ;;; Pass argument to C. (else arg))))