csi.scm

Scheme跨平台编译器

			((?)
			 (display 
			  "Toplevel commands:

 ,?                Show this text
 ,p EXP            Pretty print evaluated expression EXP
 ,d EXP            Describe result of evaluated expression EXP
 ,du EXP           Dump data of expression EXP
 ,dur EXP N        Dump range
 ,q                Quit interpreter
 ,l FILENAME ...   Load one or more files
 ,ln FILENAME ...  Load one or more files and print result of each top-level expression
 ,r                Show system information
 ,s TEXT ...       Execute shell-command
 ,tr NAME ...      Trace procedures
 ,utr NAME ...     Untrace procedures
 ,br NAME ...      Set breakpoints
 ,ubr NAME ...     Remove breakpoints
 ,uba              Remove all breakpoints
 ,breakall         Break in all threads (default)
 ,breakonly THREAD Break only in specified thread
 ,c                Continue from breakpoint
 ,info             List traced procedures and breakpoints
 ,step EXPR        Execute EXPR in single-stepping mode
 ,exn              Describe last exception
 ,t EXP            Evaluate form and print elapsed time
 ,x EXP            Pretty print macroexpanded expression EXP\n")
			 (hash-table-walk
			  command-table
			  (lambda (k v) 
			    (let ((help (cdr v)))
			      (if help
				  (print #\space help)
				  (print " ," k) ) ) ) )
			 (##sys#void) )
			(else
			 (printf "Undefined toplevel command ~s - enter `,?' for help~%" form) 
			 (##sys#void) ) ) ) ) ) )
	    (else
	     (receive rs (eval form)
	       (history-add rs)
	       (apply values rs) ) ) ) ) ) )


;;; Tracing:

(define (del x lst tst)
  (let loop ([lst lst])
    (if (null? lst)
	'()
	(let ([y (car lst)])
	  (if (tst x y)
	      (cdr lst)
	      (cons y (loop (cdr lst))) ) ) ) ) )

(define trace-indent-level 0)
(define traced-procedures '())
(define broken-procedures '())

(define trace-indent
  (lambda ()
    (write-char #\|)
    (do ((i trace-indent-level (sub1 i)))
	((<= i 0))
      (write-char #\space) ) ) )

(define traced-procedure-entry
  (lambda (name args)
    (trace-indent)
    (set! trace-indent-level (add1 trace-indent-level))
    (write (cons name args))
    (##sys#write-char-0 #\newline ##sys#standard-output) 
    (flush-output) ) )

(define traced-procedure-exit
  (lambda (name results)
    (set! trace-indent-level (sub1 trace-indent-level))
    (trace-indent)
    (write name)
    (display " -> ")
    (for-each
     (lambda (x)
       (write x)
       (write-char #\space) )
     results)
    (##sys#write-char-0 #\newline ##sys#standard-output) 
    (flush-output) ) )

(define do-trace
  (lambda (names)
    (if (null? names)
	(for-each (lambda (a) (print (car a))) traced-procedures) 
	(for-each
	 (lambda (s)
	   (let ((s (macroexpand s)))
	     (cond ((assq s traced-procedures)
		    (##sys#warn "procedure already traced" s) )
		   ((assq s broken-procedures)
		    (##sys#warn "procedure already has breakpoint") )
		   (else
		    (let ((old (##sys#slot s 0)))
		      (cond ((not (procedure? old)) (##sys#error "can not trace non-procedure" s))
			    (else
			     (set! traced-procedures (cons (cons s old) traced-procedures))
			     (##sys#setslot
			      s 0
			      (lambda args
				(traced-procedure-entry s args)
				(call-with-values (lambda () (apply old args))
				  (lambda results
				    (traced-procedure-exit s results) 
				    (apply values results) ) ) ) ) ) ) ) ) ) ) )
	 names) ) ) )

(define do-untrace 
  (lambda (names)
    (for-each
     (lambda (s)
       (let* ((s (macroexpand s))
	      (p (assq s traced-procedures)) )
	 (cond ((not p) (##sys#warn "procedure not traced" s))
	       (else
		(##sys#setslot s 0 (cdr p))
		(set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
     names) ) )

(define do-break
  (lambda (names)
    (if (null? names)
	(for-each (lambda (b) (print (car a))) broken-procedures) 
	(for-each
	 (lambda (s)
	   (let* ((s (macroexpand s))
		  (a (assq s traced-procedures)))
	     (when a
	       (##sys#warn "un-tracing procedure" s)
	       (##sys#setslot s 0 (cdr a))
	       (set! traced-procedures (del a traced-procedures eq?)) )
	     (let ((old (##sys#slot s 0)))
	       (cond ((not (procedure? old)) (##sys#error "can not set breakpoint on non-procedure" s))
		     (else
		      (set! broken-procedures (cons (cons s old) broken-procedures))
		      (##sys#setslot
		       s 0
		       (lambda args
			 (##sys#break-entry s args)
			 (##sys#apply old args) ) ) ) ) ) ) )
	 names) ) ) )

(define do-unbreak
  (lambda (names)
    (for-each
     (lambda (s)
       (let* ((s (macroexpand s))
	      (p (assq s broken-procedures)) )
	 (cond ((not p) (##sys#warn "procedure has no breakpoint" s))
	       (else
		(##sys#setslot s 0 (cdr p))
		(set! broken-procedures (del p broken-procedures eq?) ) ) ) ) )
     names) ) )

(define do-unbreak-all
  (lambda ()
    (for-each (lambda (bp)
                (##sys#setslot (car bp) 0 (cdr bp)))
              broken-procedures)
    (set! broken-procedures '())
    (##sys#void)))

;;; Parse options from string:

(define (parse-option-string str)
  (let ([ins (open-input-string str)])
    (map (lambda (o)
	   (if (string? o)
	       o
	       (let ([os (open-output-string)])
		 (write o os)
		 (get-output-string os) ) ) )
	 (handle-exceptions ex (##sys#error "invalid option syntax" str)
	   (do ([x (read ins) (read ins)]
		[xs '() (cons x xs)] )
	       ((eof-object? x) (reverse xs)) ) ) ) ) )


;;; Print status information:

(define report
  (let ((printf printf)
	(chop chop)
	(sort sort)
	(with-output-to-port with-output-to-port)
	(current-output-port current-output-port) )
    (lambda port
      (with-output-to-port (if (pair? port) (car port) (current-output-port))
	(lambda ()
	  (gc)
	  (let ([sinfo (##sys#symbol-table-info)]
		[minfo (memory-statistics)] )
	    (define (shorten n) (/ (truncate (* n 100)) 100))
	    (printf "Features:")
	    (for-each
	     (lambda (lst) 
	       (display "\n  ")
	       (for-each 
		(lambda (f)
		  (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
		lst) )
	     (chop (sort (map keyword->string ##sys#features) string<?) 5))
	    (printf "~%~
                   Machine type:    \t~A ~A~%~
                   Software type:   \t~A~%~
                   Software version:\t~A~%~
                   Build platform:  \t~A~%~
                   Include path:    \t~A~%~
                   Symbol-table load:\t~S~%  ~
                     Avg bucket length:\t~S~%  ~
                     Total symbols:\t~S~%~
                   Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~  
                     nursery size is ~S bytes, stack grows ~A~%"
		    (machine-type)
		    (if (##sys#fudge 3) "(64-bit)" "")
		    (software-type)
		    (software-version)
		    (build-platform)
		    ##sys#include-pathnames
		    (shorten (vector-ref sinfo 0))
		    (shorten (vector-ref sinfo 1))
		    (vector-ref sinfo 2)
		    (vector-ref minfo 0)
		    (if (##sys#fudge 17) " (fixed)" "")
		    (vector-ref minfo 1)
		    (vector-ref minfo 2)
		    (if (= 1 (##sys#fudge 18)) "downward" "upward") )
	    (##sys#write-char-0 #\newline ##sys#standard-output)
	    (when (##sys#fudge 14) (display "interrupts are enabled\n"))
	    (when (##sys#fudge 15) (display "symbol gc is enabled\n")) 
	    (##core#undefined) ) ) ) ) ) )


;;; Describe & dump:

(define bytevector-data
  '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)
    (s8vector "vector of signed bytes" s8vector-length s8vector-ref)
    (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)
    (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)
    (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)
    (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)
    (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)
    (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )

(define-constant max-describe-lines 40)

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

(define describe
  (let ([sprintf sprintf]
	[printf printf] 
	[fprintf fprintf]
	[length length]
	[list-ref list-ref]
	[string-ref string-ref]
	(hash-table-ref/default hash-table-ref/default)
	[hash-table-walk hash-table-walk] )
    (lambda (x . port)
      (let ([out (:optional port ##sys#standard-output)])

	(define (descseq name plen pref start)
	  (let ((len (fx- (plen x) start)))
	    (when name (fprintf out "~A of length ~S~%" name len))
	    (let loop1 ((i 0))
	      (cond ((fx>= i len))
		    ((fx>= i max-describe-lines)
		     (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )
		    (else
		     (let ((v (pref x (fx+ start i))))
		       (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))
			 (cond ((fx>= j len)
				(fprintf out " ~S: ~S" i v)
				(if (fx> n 1)
				    (fprintf out "\t(followed by ~A identical instance~a)~% ...~%" 
					     (fx- n 1)
					     (if (eq? n 2) "" "s"))
				    (newline out) )
				(loop1 (fx+ i n)) )
			       ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))
			       (else (loop2 n len)) ) ) ) ) ) ) ) )

	(when (##sys#permanent? x)
	  (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )
	(cond [(char? x)
	       (let ([code (char->integer x)])
		 (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) ]
	      [(eq? x #t) (fprintf out "boolean true~%")]
	      [(eq? x #f) (fprintf out "boolean false~%")]
	      [(null? x) (fprintf out "empty list~%")]
	      [(eof-object? x) (fprintf out "end-of-file object~%")]
	      [(eq? (##sys#void) x) (fprintf out "unspecified object~%")]
	      [(fixnum? x)
	       (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
	       (let ([code (integer->char x)])
		 (when (fx< code #x10000) (fprintf out ", character ~S" code)) )
	       (##sys#write-char-0 #\newline ##sys#standard-output) ]
	      [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
	       (fprintf out "unbound value~%") ]
	      [(##sys#number? x) (fprintf out "number ~S~%" x)]
	      [(string? x) (descseq "string" ##sys#size string-ref 0)]
	      [(vector? x) (descseq "vector" ##sys#size ##sys#slot 0)]
	      [(symbol? x)
	       (unless (##sys#symbol-has-toplevel-binding? x) (display "unbound " out))
	       (when (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0)))
		 (display "keyword " out) )
	       (fprintf out "symbol with name ~S~%" (##sys#symbol->string x)) ]
	      [(list? x) (descseq "list" length list-ref 0)]
	      [(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
	      [(procedure? x)
	       (let ([len (##sys#size x)])
		 (if (and (> len 3)