csi.scm

Scheme跨平台编译器

			  (memq #:tinyclos ##sys#features)
			  (eq? ##tinyclos#entity-tag (##sys#slot x (fx- len 1))) ) ;XXX handle this in tinyclos egg (difficult)
		     (describe-object x out)
		     (descseq 
		      (sprintf "procedure with code pointer ~X" (##sys#peek-unsigned-integer x 0))
		      ##sys#size ##sys#slot 1) ) ) ]
	      [(port? x)
	       (fprintf out
			"~A port of type ~A with name ~S and file pointer ~X~%"
			(if (##sys#slot x 1) "input" "output")
			(##sys#slot x 7)
			(##sys#slot x 3)
			(##sys#peek-unsigned-integer x 0) ) ]
	      [(and (memq #:tinyclos ##sys#features) (instance? x)) ; XXX put into tinyclos egg
	       (describe-object x out) ]
	      [(##sys#locative? x)
	       (fprintf out "locative~%  pointer ~X~%  index ~A~%  type ~A~%"
			(##sys#peek-unsigned-integer x 0)
			(##sys#slot x 1)
			(case (##sys#slot x 2) 
			  [(0) "slot"]
			  [(1) "char"]
			  [(2) "u8vector"]
			  [(3) "s8vector"]
			  [(4) "u16vector"]
			  [(5) "s16vector"]
			  [(6) "u32vector"]
			  [(7) "s32vector"]
			  [(8) "f32vector"]
			  [(9) "f64vector"] ) ) ]
	      [(##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0))]
	      [(##sys#bytevector? x)
	       (let ([len (##sys#size x)])
		 (fprintf out "blob of size ~S:~%" len)
		 (hexdump x len ##sys#byte out) ) ]
	      [(##core#inline "C_lambdainfop" x)
	       (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) ]
	      [(##sys#structure? x 'hash-table)
	       (let ((n (##sys#slot x 2)))
		 (fprintf out "hash-table with ~S element~a~%  comparison procedure: ~A~%"
			  n (if (fx= n 1) "" "s")  (##sys#slot x 3)) )
	       (fprintf out "  hash function: ~a~%" (##sys#slot x 4))
	       (hash-table-walk
		x
		(lambda (k v) (fprintf out " ~S\t-> ~S~%" k v)) ) ]
	      [(##sys#structure? x 'condition)
	       (fprintf out "condition: ~s~%" (##sys#slot x 1))
	       (for-each
		(lambda (k)
		  (fprintf out " ~s~%" k)
		  (let loop ((props (##sys#slot x 2)))
		    (unless (null? props)
		      (when (eq? k (caar props))
			(fprintf out "\t~s: ~s~%" (cdar props) (cadr props)) )
		      (loop (cddr props)) ) ) )
		(##sys#slot x 1) ) ]
	      [(and (##sys#structure? x 'meroon-instance) (provided? 'meroon)) ; XXX put this into meroon egg (really!)
	       (unveil x out) ]
	      [(##sys#generic-structure? x)
	       (let ([st (##sys#slot x 0)])
		 (cond ((hash-table-ref/default describer-table st #f) => (cut <> x out))
		       ((assq st bytevector-data) =>
			(lambda (data)
			  (apply descseq (append (map eval (cdr data)) (list 0)))) )
		       (else
			(fprintf out "structure of type `~S':~%" (##sys#slot x 0))
			(descseq #f ##sys#size ##sys#slot 1) ) ) ) ]
	      [else (fprintf out "unknown object~%")] )
	(##sys#void) ) ) ) )

(define set-describer!
  (let ((hash-table-set! hash-table-set!))
    (lambda (tag proc)
      (hash-table-set! describer-table tag proc) ) ) )


;;; Display hexdump:

(define dump
  (lambda (x . len-out)
    (let-optionals len-out
	([len #f]
	 [out ##sys#standard-output] )
      (define (bestlen n) (if len (min len n) n))
      (cond [(##sys#immediate? x) (##sys#error 'dump "can not dump immediate object" x)]
	    [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
	    [(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
	    [(and (not (##sys#immediate? x)) (##sys#pointer? x))
	     (hexdump x 32 ##sys#peek-byte out) ]
	    [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
	     (let ([bv (##sys#slot x 1)])
	       (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
	    [else (##sys#error 'dump "can not dump object" x)] ) ) ) )

(define hexdump
  (let ([display display]
	[string-append string-append]
	[make-string make-string]
	[write-char write-char] )
    (lambda (bv len ref out)

      (define (justify n m base lead)
	(let* ([s (number->string n base)]
	       [len (##sys#size s)] )
	  (if (fx< len m)
	      (string-append (make-string (fx- m len) lead) s)
	      s) ) )

      (do ([a 0 (fx+ a 16)])
	  ((fx>= a len))
	(display (justify a 4 10 #\space) out)
	(write-char #\: out)
	(do ([j 0 (fx+ j 1)]
	     [a a (fx+ a 1)] )
	    ((or (fx>= j 16) (fx>= a len))
	     (and-let* ([(fx>= a len)]
			[o (fxmod len 16)]
			[(not (fx= o 0))] )
	       (do ([k (fx- 16 o) (fx- k 1)])
		   ((fx= k 0))
		 (display "   " out) ) ) )
	  (write-char #\space out)
	  (display (justify (ref bv a) 2 16 #\0) out) )
	(write-char #\space out)
	(do ([j 0 (fx+ j 1)]
	     [a a (fx+ a 1)] )
	    ((or (fx>= j 16) (fx>= a len)))
	  (let ([c (ref bv a)])
	    (if (and (fx>= c 32) (fx< c 128))
		(write-char (integer->char c) out)
		(write-char #\. out) ) ) ) 
	(##sys#write-char-0 #\newline out) ) ) ) )


;;; Start interpreting:

(define (deldups lis . maybe-=)
  (let ((elt= (:optional maybe-= equal?)))
    (let recur ((lis lis))
      (if (null? lis) lis
	  (let* ((x (car lis))
		 (tail (cdr lis))
		 (new-tail (recur (del x tail elt=))))
	    (if (eq? tail new-tail) lis (cons x new-tail)))))))

(define (member* keys set)
  (let loop ((set set))
    (and (pair? set)
	 (let find ((ks keys))
	   (cond ((null? ks) (loop (cdr set)))
		 ((equal? (car ks) (car set)) set)
		 (else (find (cdr ks))) ) ) ) ) )

(define-constant short-options 
  '(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P) )

(define-constant long-options
  '("-keyword-style" "-script" "-version" "-help" "--help" "--" "-feature" 
    "-eval" "-case-insensitive"
    "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init" 
    "-include-path" "-release" "-ss"
    "-print" "-pretty-print") )

(define (canonicalize-args args)
  (let loop ((args args))
    (if (null? args)
	'()
	(let ((x (car args)))
	  (cond 
	   ((member x '("-s" "-ss" "-script" "--")) args)
	   ((and (fx> (##sys#size x) 2)
		 (char=? #\- (##core#inline "C_subchar" x 0))
		 (not (member x long-options)) )
	    (if (char=? #\: (##core#inline "C_subchar" x 1))
		(loop (cdr args))
		(let ((cs (string->list (substring x 1))))
		  (if (findall cs short-options)
		      (append (map (cut string #\- <>) cs) (loop (cdr args)))
		      (##sys#error "invalid option" x) ) ) ) )
	   (else (cons x (loop (cdr args)))))))))

(define (findall chars clist)
  (let loop ((chars chars))
    (or (null? chars)
	(and (memq (car chars) clist)
	     (loop (cdr chars))))))

(define (run)
  (let* ([extraopts (parse-option-string (or (getenv "CSI_OPTIONS") ""))]
	 [args (canonicalize-args (command-line-arguments))]
	 [kwstyle (member* '("-k" "-keyword-style") args)]
	 [script (member* '("-s" "-ss" "-script") args)])
    (cond [script
	   (when (or (not (pair? (cdr script)))
		     (zero? (string-length (cadr script)))
		     (char=? #\- (string-ref (cadr script) 0)) )
	     (##sys#error "missing or invalid script argument"))
	   (program-name (cadr script))
	   (command-line-arguments (cddr script))
	   (register-feature! 'script)
	   (set-cdr! (cdr script) '()) 
	   (when ##sys#windows-platform
	     (and-let* ((sname (lookup-script-file (cadr script))))
	       (set-car! (cdr script) sname) ) ) ]
	  [else
	   (set! args (append (canonicalize-args extraopts) args))
	   (and-let* ([p (member "--" args)])
	     (set-cdr! p '()) ) ] )
    (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]
	   [batch (or script (member* '("-b" "-batch") args) eval?)]
	   [quietflag (member* '("-q" "-quiet") args)]
	   [quiet (or script quietflag eval?)]
	   [ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))] )      
      (define (collect-options opt)
	(let loop ([opts args])
	  (cond [(member opt opts) 
		 => (lambda (p)
		      (if (null? (cdr p))
			  (##sys#error "missing argument to command-line option" opt)
			  (cons (cadr p) (loop (cddr p)))) ) ]
		[else '()] ) ) )
      (define (loadinit)
	(let ([fn (##sys#string-append "./" init-file)])
	  (if (file-exists? fn)
	      (load fn)
	      (let* ([prefix (chop-separator (or (getenv "HOME") "."))]
		     [fn (string-append prefix "/" init-file)] )
		(when (file-exists? fn) 
		  (load fn) ) ) ) ) )
      (define (evalstring str #!optional (rec (lambda _ (void))))
	(let ((in (open-input-string str)))
	  (do ([x (read in) (read in)])
	      ((eof-object? x))
	    (rec (receive (eval x))) ) ) )
      (when quietflag (set! ##sys#eval-debug-level 0))
      (when (member* '("-h" "-help" "--help") args)
	(print-usage)
	(exit 0) )
      (when (member* '("-v" "-version") args)
	(print-banner)
	(exit 0) )
      (when (member "-release" args)
	(print (chicken-version))
	(exit 0) )
      (when (member* '("-w" "-no-warnings") args)
	(unless quiet (display "Warnings are disabled\n"))
	(set! ##sys#warnings-enabled #f) )
      (unless quiet
	(load-verbose #t)
	(print-banner) )
      (when (member* '("-i" "-case-insensitive") args)
	(unless quiet (display "Identifiers and symbols are case insensitive\n"))
	(register-feature! 'case-insensitive)
	(case-sensitive #f) )
      (for-each register-feature! (collect-options "-feature"))
      (for-each register-feature! (collect-options "-D"))
      (set! ##sys#include-pathnames 
	(deldups
	 (append (map chop-separator (collect-options "-include-path"))
		 (map chop-separator (collect-options "-I"))
		 ##sys#include-pathnames
		 ipath)
	 string=?) )
      (set! ##sys#features (cons #:match ##sys#features))
      (provide 'match)
      (when kwstyle
	(cond [(not (pair? (cdr kwstyle)))
	       (##sys#error "missing argument to `-keyword-style' option") ]
	      [(string=? "prefix" (cadr kwstyle))
	       (keyword-style #:prefix) ]
	      [(string=? "none" (cadr kwstyle))
	       (keyword-style #:none) ]
	      [(string=? "suffix" (cadr kwstyle))
	       (keyword-style #:suffix) ] ) )
      (unless (or (member* '("-n" "-no-init") args) script) (loadinit))
      (do ([args args (cdr args)])
	  ((null? args)
	   (unless batch 
	     (repl)
	     (##sys#write-char-0 #\newline ##sys#standard-output) ) )
	(let* ([arg (car args)]
	       [len (string-length arg)] )
	  (cond ((member 
		  arg 
		  '("--" "-batch" "-quiet" "-no-init" "-no-warnings" "-script"
		    "-b" "-q" "-n" "-w" "-s" "-i"
		    "-case-insensitive" "-ss") ) )
		((member arg '("-feature" "-include-path" "-keyword-style" 
			       "-D" "-I" "-k"))
		 (set! args (cdr args)) )
		((or (string=? "-R" arg) (string=? "-require-extension" arg))
		 (eval `(##core#require-extension ',(string->symbol (cadr args))))
		 (set! args (cdr args)) )
		((or (string=? "-e" arg) (string=? "-eval" arg))
		 (evalstring (cadr args))
		 (set! args (cdr args)) )
		((or (string=? "-p" arg) (string=? "-print" arg))
		 (evalstring 
		  (cadr args)
		  (cut for-each print <...>) )
		 (set! args (cdr args)) )
		((or (string=? "-P" arg) (string=? "-pretty-print" arg))
		 (evalstring 
		  (cadr args)
		  (cut for-each pretty-print <...>) )
		 (set! args (cdr args)) )
		(else
		 (load arg) 
		 (when (and script (string=? "-ss" (car script)))
		   (call-with-values (cut main (command-line-arguments))
		     (lambda results
		       (exit
			(if (and (pair? results) (fixnum? (car results)))
			    (car results)
			    0) ) ) ) ) ) ) ) ) ) ) )

(run)