csi.scm

Scheme跨平台编译器

;;;; csi.scm - Interpreter stub for CHICKEN
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare (uses match srfi-69 ports))

(declare
  (usual-integrations)
  (disable-interrupts)
  (disable-warning var)
  (run-time-macros)
  (foreign-declare #<<EOF
#if (defined(_MSC_VER) && defined(_WIN32)) || defined(HAVE_DIRECT_H)
# include <direct.h>
#else
# define _getcwd(buf, len)       NULL
#endif
EOF
) )

(include "chicken-more-macros")
(include "banner")

(private csi 
  print-usage print-banner
  run hexdump del 
  parse-option-string chop-separator lookup-script-file
  report describe dump hexdump bytevector-data get-config
  deldups tty-input?
  history-list history-count history-add history-ref
  trace-indent trace-indent-level traced-procedure-entry traced-procedure-exit)

(declare
  (always-bound
    ##sys#windows-platform)
  (hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
	traced-procedures describer-table dirseparator?
	findall trace-indent command-table do-break do-unbreak broken-procedures) )


;;; Parameters:

(define-constant init-file ".csirc")

(set! ##sys#repl-print-length-limit 2048)
(set! ##sys#features (cons #:csi ##sys#features))


;;; Print all sorts of information:

(define (print-usage)
  (display
"Usage: csi {FILENAME | OPTION}

  where OPTION may be one of the following:

    -h  -help  --help           display this text and exit
    -v  -version                display version and exit
        -release                print release number and exit
    -i  -case-insensitive       enable case-insensitive reading
    -e  -eval EXPRESSION        evaluate given expression
    -p  -print EXPRESSION       evaluate and print result(s)
    -P  -pretty-print EXPRESSION  evaluate and print result(s) prettily
    -D  -feature SYMBOL         register feature identifier
    -q  -quiet                  do not print banner
    -n  -no-init                do not load initialization file `")
  (display init-file)
  (display 
"'
    -b  -batch                  terminate after command-line processing
    -w  -no-warnings            disable all warnings
    -k  -keyword-style STYLE    enable alternative keyword-syntax (none, prefix or suffix)
    -s  -script PATHNAME        use interpreter for shell scripts
        -ss PATHNAME            shell script with `main' procedure
    -R  -require-extension NAME require extension before executing code
    -I  -include-path PATHNAME  add PATHNAME to include path
    --                          ignore all following options

") )

(define (print-banner)
  (print +banner+ (chicken-version #t) "\n") )


;;; Reader for REPL history:

(set! ##sys#user-read-hook
  (let ([read-char read-char]
	[read read]
	[old-hook ##sys#user-read-hook] )
    (lambda (char port)
      (cond [(or (char=? #\) char) (char-whitespace? char))
	     `',(history-ref (fx- history-count 1)) ]
	    [else (old-hook char port)] ) ) ) )

(set! ##sys#sharp-number-hook
  (lambda (port n)
    `',(history-ref n) ) )


;;; Chop terminating separator from pathname:

(define (dirseparator? c)
  (or (char=? c #\\) (char=? c #\/)))

(define chop-separator 
  (let ([substring substring] )
    (lambda (str)
      (let* ((len (sub1 (##sys#size str)))
	     (c (string-ref str len)))
	(if (and (fx> len 0) (dirseparator? c))
	    (substring str 0 len)
	    str) ) ) ) )


;;; Find script in PATH (only used for Windows/DOS):

(define @ #f)

(define lookup-script-file 
  (let* ([buf (make-string 256)]
	 [_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )
    (define (addext name)
      (if (file-exists? name)
	  name
	  (let ([n2 (string-append name ".bat")])
	    (and (file-exists? n2) n2) ) ) )
    (define (string-index proc str1)
      (let ((len (##sys#size str1)))
	(let loop ((i 0))
	  (cond ((fx>= i len) #f)
		((proc (##core#inline "C_subchar" str1 i)) i)
		(else (loop (fx+ i 1))) ) ) ) )
    (lambda (name)
      (let ([path (getenv "PATH")])
	(and (> (##sys#size name) 0)
	     (cond [(dirseparator? (string-ref name 0)) (addext name)]
		   [(string-index dirseparator? name)
		    (and-let* ([p (_getcwd buf 256)])
		      (addext (string-append (chop-separator p) "/" name)) ) ]
		   [(addext name)]
		   [else
		    (let ([name2 (string-append "/" name)])
		      (let loop ([ps (string-split path ";")])
			(and (pair? ps)
			     (let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])
			       (or (addext name2)
				   (loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )
				   

;;; REPL customization:

(define history-list (make-vector 32))
(define history-count 1)

(define history-add
  (let ([vector-resize vector-resize])
    (lambda (vals)
      (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]
	    [size (##sys#size history-list)] )
	(when (fx>= history-count size)
	  (set! history-list (vector-resize history-list (fx* 2 size))) )
	(vector-set! history-list history-count x)
	(set! history-count (fx+ history-count 1))
	x) ) ) )

(define (history-ref index)
  (let ([i (inexact->exact index)])
    (if (and (fx> i 0) (fx<= i history-count))
	(vector-ref history-list i) 
	(##sys#error "history entry index out of range" index) ) ) )

(repl-prompt
 (let ([sprintf sprintf])
   (lambda ()
     (sprintf "#;~A> " history-count) ) ) )

(define (tty-input?)
  (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) )

(set! ##sys#break-on-error #f)

(set! ##sys#read-prompt-hook
  (let ([old ##sys#read-prompt-hook])
    (lambda ()
      (when (tty-input?) (old)) ) ) )

(define command-table (make-hash-table eq?))

(define toplevel-command
  (let ((hash-table-set! hash-table-set!))
    (lambda (name proc #!optional help)
      (##sys#check-symbol name 'toplevel-command)
      (when help (##sys#check-string help 'toplevel-command))
      (hash-table-set! command-table name (cons proc help)) ) ) )

(set! ##sys#repl-eval-hook
  ;; `macroexpand' is intentionally not shadowed (psyntax redefines it).
  (let ((eval eval)
	(load-noisily load-noisily)
	(read read)
	(singlestep singlestep)
	(hash-table-ref hash-table-ref)
	(hash-table-walk hash-table-walk)
	(read-line read-line)
	(length length)
	(display display)
	(write write)
	(string-split string-split)
	(printf printf)
	(pretty-print pretty-print)
	(integer? integer?)
	(values values) )
    (lambda (form)
      (set! trace-indent-level 0)
      (cond ((eof-object? form) (exit))
	    ((and (pair? form)
		  (eq? 'unquote (##sys#slot form 0)) )
	     (let ((cmd (cadr form)))
	       (cond ((and (symbol? cmd) (hash-table-ref/default command-table cmd #f)) =>
		      (lambda (p)
			((car p))
			(##sys#void) ) )
		     (else
		      (case cmd
			((x)
			 (let ([x (read)])
			   (pretty-print (macroexpand x))
			   (##sys#void) ) )
			((p)
			 (let* ([x (read)]
				[xe (eval x)] )
			   (pretty-print xe)
			   (##sys#void) ) )
			((d)
			 (let* ([x (read)]
				[xe (eval x)] )
			   (describe xe) ) )
			((du)
			 (let* ([x (read)]
				[xe (eval x)] )
			   (dump xe) ) )
			((dur)
			 (let* ([x (read)]
				[n (read)]
				[xe (eval x)] 
				[xn (eval n)] )
			   (dump xe xn) ) )
			((r) (report))
			((q) (exit))
			((l)
			 (let ((fns (string-split (read-line))))
			   (for-each load fns)
			   (##sys#void) ) )
			((ln) 
			 (let ((fns (string-split (read-line))))
			   (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)
			   (##sys#void) ) )
			((t)
			 (let ((x (read)))
			   (receive rs (time (eval x))
			     (history-add rs)
			     (apply values rs) ) ) )
			((tr) (do-trace (map string->symbol (string-split (read-line)))))
			((utr) (do-untrace (map string->symbol (string-split (read-line)))))
			((br) (do-break (map string->symbol (string-split (read-line)))))
			((ubr) (do-unbreak (map string->symbol (string-split (read-line)))))
			((uba) (do-unbreak-all))
			((breakall) 
			 (set! ##sys#break-in-thread #f) ) 
			((breakonly)
			 (set! ##sys#break-in-thread (eval (read))) )
			((info)
			 (when (pair? traced-procedures)
			   (printf "Traced: ~s~%" (map car traced-procedures)) )
			 (when (pair? broken-procedures)
			   (printf "Breakpoints: ~s~%" (map car broken-procedures)) ) )
			((c)
			 (cond (##sys#last-breakpoint
				(let ((exn ##sys#last-breakpoint))
				  (set! ##sys#last-breakpoint #f)
				  (##sys#break-resume exn) ) )
			       (else (display "no breakpoint pending\n") ) ) )
			((exn) 
			 (when ##sys#last-exception
			   (history-add (list ##sys#last-exception))
			   (describe ##sys#last-exception) ) )
			((step)
			 (let ((x (read)))
			   (read-line)
			   (singlestep (eval `(lambda () ,x))) ) )
			((s)
			 (let* ((str (read-line))
				(r (system str)) )
			   (history-add (list r))
			   r) )