support.scm

Scheme跨平台编译器

	  ((let) 
	   (walk (first subs) e)
	   (walk (second subs) (append params e)) )
	  ((##core#lambda)
	   (decompose-lambda-list
	    (third params)
	    (lambda (vars argc rest)
	      (walk (first subs) (append vars e)) ) ) )
	  (else (walkeach subs e)) ) ) )

    (define (walkeach ns e)
      (for-each (lambda (n) (walk n e)) ns) )

    (walk node '())
    vars) )


;;; Simple topological sort:
;
; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt

(define (topological-sort dag pred)
  (if (null? dag)
      '()
      (let* ((adj-table '())
	     (sorted '()))

	(define (insert x y)
	  (let loop ([at adj-table])
	    (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
		  [(pred x (caar at)) (set-cdr! (car at) y)]
		  [else (loop (cdr at))] ) ) )
	
	(define (lookup x)
	  (let loop ([at adj-table])
	    (cond [(null? at) #f]
		  [(pred x (caar at)) (cdar at)]
		  [else (loop (cdr at))] ) ) )
	
	(define (visit u adj-list)
	  ;; Color vertex u
	  (insert u 'colored)
	  ;; Visit uncolored vertices which u connects to
	  (for-each (lambda (v)
		      (let ((val (lookup v)))
			(if (not (eq? val 'colored))
			    (visit v (or val '())))))
		    adj-list)
	  ;; Since all vertices downstream u are visited
	  ;; by now, we can safely put u on the output list
	  (set! sorted (cons u sorted)) )
	
	;; Hash adjacency lists
	(for-each (lambda (def) (insert (car def) (cdr def)))
		  (cdr dag))
	;; Visit vertices
	(visit (caar dag) (cdar dag))
	(for-each (lambda (def)
		    (let ((val (lookup (car def))))
		      (if (not (eq? val 'colored))
			  (visit (car def) (cdr def)))))
		  (cdr dag)) 
	sorted) ) )


;;; Some pathname operations:

(define (chop-separator str)
  (let ([len (sub1 (string-length str))])
    (if (and (> len 0) 
	     (memq (string-ref str len) '(#\\ #\/)))
	(substring str 0 len)
	str) ) )

(define (chop-extension str)
  (let ([len (sub1 (string-length str))])
    (let loop ([i len])
      (cond [(zero? i) str]
	    [(char=? #\. (string-ref str i)) (substring str 0 i)]
	    [else (loop (sub1 i))] ) ) ) )


;;; Print version/usage information:

(define (print-version #!optional b)
  (when b (print* +banner+))
  (print (chicken-version #t)) )

(define (print-usage)
  (print-version)
  (newline)
  (display #<<EOF
Usage: chicken FILENAME OPTION ...

  FILENAME should be a complete source file name with extension, or "-" for
  standard input. OPTION may be one of the following:

  General options:

    -help                       display this text and exit
    -version                    display compiler version and exit
    -release                    print release number and exit
    -verbose                    display information on compilation progress
    -quiet                      do not display compile information

  File and pathname options:

    -output-file FILENAME       specifies output-filename, default is 'out.c'
    -include-path PATHNAME      specifies alternative path for included files
    -to-stdout                  write compiled file to stdout instead of file

  Language options:

    -feature SYMBOL             register feature identifier

  Syntax related options:

    -case-insensitive           don't preserve case of read symbols
    -keyword-style STYLE        allow alternative keyword syntax (none, prefix or suffix)
    -run-time-macros            macros are made available at run-time

  Translation options:

    -explicit-use               do not use units 'library' and 'eval' by default
    -check-syntax               stop compilation after macro-expansion
    -analyze-only               stop compilation after first analysis pass

  Debugging options:

    -no-warnings                disable warnings
    -disable-warning CLASS      disable specific class of warnings
    -debug-level NUMBER         set level of available debugging information
    -no-trace                   disable tracing information
    -profile                    executable emits profiling information 
    -profile-name FILENAME      name of the generated profile information file
    -accumulate-profile         executable emits profiling information in append mode
    -no-lambda-info             omit additional procedure-information
    -emit-exports FILENAME      write exported toplevel variables to FILENAME
    -check-imports              look for undefined toplevel variables
    -import FILENAME            read externally exported symbols from FILENAME

  Optimization options:

    -optimize-level NUMBER      enable certain sets of optimization options
    -optimize-leaf-routines     enable leaf routine optimization
    -lambda-lift                enable lambda-lifting
    -no-usual-integrations      standard procedures may be redefined
    -unsafe                     disable safety checks
    -block                      enable block-compilation
    -disable-interrupts         disable interrupts in compiled code
    -fixnum-arithmetic          assume all numbers are fixnums
    -benchmark-mode             fixnum mode, no interrupts and opt.-level 3
    -disable-stack-overflow-checks  disables detection of stack-overflows.
    -inline                     enable inlining
    -inline-limit               set inlining threshold

  Configuration options:

    -unit NAME                  compile file as a library unit
    -uses NAME                  declare library unit as used.
    -heap-size NUMBER           specifies heap-size of compiled executable
    -heap-initial-size NUMBER   specifies heap-size at startup time
    -heap-growth PERCENTAGE     specifies growth-rate of expanding heap
    -heap-shrinkage PERCENTAGE  specifies shrink-rate of contracting heap
    -nursery NUMBER
    -stack-size NUMBER          specifies nursery size of compiled executable
    -extend FILENAME            load file before compilation commences
    -prelude EXPRESSION         add expression to front of source file
    -postlude EXPRESSION        add expression to end of source file
    -prologue FILENAME          include file before main source file
    -epilogue FILENAME          include file after main source file
    -dynamic                    compile as dynamically loadable code
    -require-extension NAME     require extension NAME in compiled code
    -extension                  compile as extension (dynamic or static)

  Obscure options:

    -debug MODES                display debugging output for the given modes
    -unsafe-libraries           marks the generated file as being linked
                                with the unsafe runtime system
    -raw                        do not generate implicit init- and exit code			       
    -emit-external-prototypes-first  emit protoypes for callbacks before foreign
                                declarations

EOF
) )


;;; Special block-variable literal type:

(define-record block-variable-literal 
  name)					; symbol


;;; Generation of random names:

(define (make-random-name . prefix)
  (string->symbol
   (sprintf "~A-~A~A"
	    (:optional prefix (gensym))
	    (current-seconds)
	    (random 1000) ) ) )


;;; Register/lookup real names:
;
; - The real-name-table contains the following mappings:
;
;     <variable-alias> -> <variable>
;     <lambda-id> -> <variable> or <variable-alias>

(define (set-real-name! name rname)
  (##sys#hash-table-set! real-name-table name rname) )

(define (real-name var . db)
  (define (resolve n)
    (let ([n2 (##sys#hash-table-ref real-name-table n)])
      (if n2
	  (or (##sys#hash-table-ref real-name-table n2)
	      n2) 
	  n) ) )
  (let ([rn (resolve var)])
    (cond [(not rn) (##sys#symbol->qualified-string var)]
	  [(pair? db)
	   (let ([db (car db)])
	     (let loop ([prev (##sys#symbol->qualified-string rn)] 
			[container (get db var 'contained-in)] )
	       (if container
		   (let ([rc (resolve container)])
		     (if (eq? rc container)
			 prev
			 (loop (sprintf "~A in ~A" prev rc)
			       (get db container 'contained-in) ) ) )
		   prev) ) ) ]
	  [else (##sys#symbol->qualified-string rn)] ) ) )

(define (real-name2 var db)
  (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
    (real-name rn db) ) )

(define (display-real-name-table)
  (##sys#hash-table-for-each
   (lambda (key val)
     (printf "~S\t~S~%" key val) )
   real-name-table) )

(define (source-info->string info)
  (match info
    ((file ln name)
     (let ((lns (->string ln)))
       (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
    (_ (and info (->string info))) ) )


;;; We need this for constant folding:

(define (string-null? x) (string-null? x))


;;; Dump node structure:

(define (dump-nodes n)
  (let loop ([i 0] [n n])
    (let ([class (node-class n)]
	  [params (node-parameters n)]
	  [subs (node-subexpressions n)] 
	  [ind (make-string i #\space)] 
	  [i2 (+ i 2)] )
      (printf "~%~A<~A ~S" ind class params)
      (for-each (cut loop i2 <>) subs)
      (let ([len (##sys#size n)])
	(when (fx> len 4)
	  (printf "[~S" (##sys#slot n 4))
	  (do ([i 5 (fx+ i 1)])
	      ((fx>= i len))
	    (printf " ~S" (##sys#slot n i)) )
	  (write-char #\]) ) )
      (write-char #\>) ) )
  (newline) )


;;; "#> ... <#" syntax:

(set! ##sys#user-read-hook
  (let ([old-hook ##sys#user-read-hook])
    (lambda (char port)
      (if (char=? #\> char)	       
	  (let* ((_ (read-char port))		; swallow #\>
		 (text (scan-sharp-greater-string port)))
	    `(declare (foreign-declare ,text)) )
	  (old-hook char port) ) ) ) )

(define (scan-sharp-greater-string port)
  (let ([out (open-output-string)])
    (let loop ()
      (let ([c (read-char port)])
	(cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
	      [(char=? c #\newline)
	       (newline out)
	       (loop) ]
	      [(char=? c #\<)
	       (let ([c (read-char port)])
		 (if (eqv? #\# c)
		     (get-output-string out)
		     (begin
		       (write-char #\< out)
		       (write-char c out) 
		       (loop) ) ) ) ]
	      [else
	       (write-char c out)
	       (loop) ] ) ) ) ) )


;;; Custom declarations:

(define (process-custom-declaration spec strings)
  (let* ([tag (car spec)]
	 [name (cadr spec)]
	 [fname (caddr spec)]
	 [args (cdddr spec)] 
	 [id (cons tag name)]
	 [a (assoc id custom-declare-alist)] )
    (unless a
      (let ([out (open-output-file fname)])
	(set! a (cons id out))
	(set! custom-declare-alist (cons a custom-declare-alist))
	(set! compiler-cleanup-hook
	  (let ([old compiler-cleanup-hook])
	    (lambda ()
	      (close-output-port out)
	      (old) ) ) )
	(emit-control-file-item (cons* tag name fname args)) ) )
    (for-each (cute display <> (cdr a)) strings) ) )

(define (emit-control-file-item item)
  (unless csc-control-file
    (set! csc-control-file (open-output-file (pathname-replace-extension source-filename "csc")))
    (display "#%csc\n" csc-control-file) 
    (set! compiler-cleanup-hook
      (let ([old compiler-cleanup-hook])
	(lambda ()
	  (close-output-port csc-control-file)
	  (old) ) ) ) )
  (fprintf csc-control-file "~S~%" item) )


;;; Compiler macro registration

(define (register-compiler-macro name llist body)
  (unless compiler-macro-table
    (set! compiler-macro-table (make-vector 301 '())) )
  (call/cc
   (lambda (return)
     (let* ((wvar (gensym))
	    (llist
	     (let loop ((llist llist))
	       (cond ((not (pair? llist)) llist)
		     ((eq? #:whole (car llist))
		      (unless (pair? (cdr llist))
			(return #f) )
		      (set! wvar (cadr llist))
		      (cddr llist) )
		     (else (cons (car llist) (loop (cdr llist)))) ) ) ) )
       (##sys#hash-table-set!
	compiler-macro-table
	name
	(eval `(lambda (,wvar) (apply (lambda ,llist ,@body) (cdr ,wvar))) ) )
       #t) ) ) )


;;; 64-bit fixnum?

(define (big-fixnum? x)
  (and (fixnum? x)
       (##sys#fudge 3)			; 64 bit?
       (or (fx> x 1073741823)
	   (fx< x -1073741824) ) ) )