~ chicken-core (master) /csi.scm
Trap1;;;; csi.scm - Interpreter stub for CHICKEN2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (usual-integrations)30 (disable-interrupts)31 (always-bound ##sys#windows-platform)32 (foreign-declare #<<EOF33#include <signal.h>3435#if defined(HAVE_DIRECT_H)36# include <direct.h>37#else38# define _getcwd(buf, len) NULL39#endif40EOF41) )4243(module chicken.csi44 (editor-command toplevel-command default-evaluator)4546(import scheme47 chicken.base48 chicken.condition49 chicken.fixnum50 chicken.foreign51 chicken.format52 chicken.file53 chicken.gc54 chicken.internal55 chicken.io56 chicken.keyword57 chicken.load58 chicken.pathname59 chicken.platform60 chicken.port61 chicken.pretty-print62 chicken.process63 chicken.process-context64 chicken.repl65 chicken.sort66 chicken.string67 chicken.syntax68 chicken.time)6970(import (rename (only (scheme write) write) (write write/labels)))71(import (only (scheme base) make-parameter open-input-string open-output-string72 get-output-string port?))7374(include "banner.scm")75(include "mini-srfi-1.scm")7677;;; Parameters:7879(define-constant init-file "csirc")8081(set! ##sys#repl-print-length-limit 2048)82(set! ##sys#features (cons #:csi ##sys#features))83(set! ##sys#notices-enabled #t)8485(set! ##sys#repl-print-hook86 (lambda (o p)87 (write/labels o p)88 (newline)))8990(define editor-command (make-parameter #f))91(define selected-frame #f)9293(define default-editor94 (or (get-environment-variable "EDITOR")95 (get-environment-variable "VISUAL")96 (if (get-environment-variable "EMACS")97 "emacsclient"98 "vi"))) ; shudder99100101;;; Print all sorts of information:102103(define (print-usage)104 (display #<<EOF105usage: csi [OPTION ...] [FILENAME ...]106107 `csi' is the CHICKEN interpreter.108109 FILENAME is a Scheme source file name with optional extension. OPTION may be110 one of the following:111112 -h -help display this text and exit113 -version display version and exit114 -release print release number and exit115 -i -case-insensitive enable case-insensitive reading116 -e -eval EXPRESSION evaluate given expression117 -p -print EXPRESSION evaluate and print result(s)118 -P -pretty-print EXPRESSION evaluate and print result(s) prettily119 -D -feature SYMBOL register feature identifier120 -no-feature SYMBOL disable built-in feature identifier121 -q -quiet do not print banner122123EOF124)125 (display #<#EOF126 -n -no-init do not load initialization file #{#\`} #{init-file} #{#\'}127128EOF129)130 (display #<<EOF131 -b -batch terminate after command-line processing132 -w -no-warnings disable all warnings133 -K -keyword-style STYLE enable alternative keyword-syntax134 (prefix, suffix or none)135 -no-parentheses-synonyms disables list delimiter synonyms136 -r7rs-syntax disables the CHICKEN extensions to137 R7RS syntax138 -s -script PATHNAME use csi as interpreter for Scheme scripts139 -ss PATHNAME same as `-s', but invoke `main' procedure140 -sx PATHNAME same as `-s', but print each expression141 as it is evaluated142 -setup-mode prefer the current directory when locating extensions143 -R -require-extension NAME require extension and import before144 executing code145 -I -include-path PATHNAME add PATHNAME to include path146 -- ignore all following options147148EOF149) ) ;| <--- for emacs font-lock150151(define (print-banner)152 (print +banner+ (chicken-version #t) "\n"))153154155;;; Chop terminating separator from pathname:156157(define (dirseparator? c)158 (or (and ##sys#windows-platform (char=? c #\\))159 (char=? c #\/)))160161(define chop-separator162 (let ([substring substring] )163 (lambda (str)164 (let* ((len (sub1 (string-length str)))165 (c (string-ref str len)))166 (if (and (fx> len 0) (dirseparator? c))167 (substring str 0 len)168 str) ) ) ) )169170171;;; Find script in PATH (only used for Windows/DOS):172173(define lookup-script-file174 (let* ([buf (make-string 256)]175 [_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )176 (define (addext name)177 (if (file-exists? name)178 name179 (let ([n2 (string-append name ".bat")])180 (and (file-exists? n2) n2) ) ) )181 (define (string-index proc str1)182 (let ((len (string-length str1)))183 (let loop ((i 0))184 (cond ((fx>= i len) #f)185 ((proc (string-ref str1 i)) i)186 (else (loop (fx+ i 1))) ) ) ) )187 (lambda (name)188 (let ([path (get-environment-variable "PATH")])189 (and (> (string-length name) 0)190 (cond [(dirseparator? (string-ref name 0)) (addext name)]191 [(string-index dirseparator? name)192 (let ((p (_getcwd buf 256)))193 (addext (string-append (chop-separator p) "/" name)) ) ]194 [(addext name)]195 [else196 (let ([name2 (string-append "/" name)])197 (let loop ((ps (##sys#split-path path)))198 (and (pair? ps)199 (let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])200 (or (addext name2)201 (loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )202203204205;;; REPL history references:206207(define history-list (make-vector 32))208(define history-count 1)209210(define history-add211 (let ([vector-resize vector-resize])212 (lambda (vals)213 (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]214 [size (##sys#size history-list)] )215 (when (fx>= history-count size)216 (set! history-list (vector-resize history-list (fx* 2 size))) )217 (vector-set! history-list history-count x)218 (set! history-count (fx+ history-count 1))219 x) ) ) )220221(define (history-clear)222 (vector-fill! history-list (##sys#void)))223224(define history-show225 (let ((newline newline))226 (lambda ()227 (do ((i 1 (fx+ i 1)))228 ((>= i history-count))229 (printf "#~a: " i)230 (##sys#with-print-length-limit231 80232 (lambda ()233 (##sys#print (vector-ref history-list i) #t ##sys#standard-output)))234 (newline)))))235236(define (history-ref index)237 (let ([i (inexact->exact index)])238 (if (and (fx> i 0) (fx<= i history-count))239 (vector-ref history-list i)240 (##sys#error "history entry index out of range" index) ) ) )241242;;; Reader hooks for REPL history:243244(define (register-repl-history!)245 (set! ##sys#user-read-hook246 (let ((old-hook ##sys#user-read-hook))247 (lambda (char port)248 (cond ((or (char=? #\) char) (char-whitespace? char))249 `',(history-ref (fx- history-count 1)))250 (else (old-hook char port))))))251 (set! ##sys#sharp-number-hook252 (lambda (port n) `',(history-ref n))))253254(repl-prompt255 (let ((sprintf sprintf))256 (lambda ()257 (sprintf "#;~A~A> "258 (let ((m (##sys#current-module)))259 (if m260 (sprintf "~a:" (##sys#module-name m))261 ""))262 history-count))))263264265;;; Other REPL customizations:266267(define (tty-input?)268 (or (##core#inline "C_i_tty_forcedp")269 (##sys#tty-port? ##sys#standard-input)))270271(set! ##sys#read-prompt-hook272 (let ([old ##sys#read-prompt-hook])273 (lambda ()274 (when (tty-input?) (old)) ) ) )275276(define command-table '())277278(define (toplevel-command name proc #!optional help)279 (##sys#check-symbol name 'toplevel-command)280 (when help (##sys#check-string help 'toplevel-command))281 (cond ((assq name command-table) =>282 (lambda (a)283 (set-cdr! a (list proc help)) ))284 (else285 (set! command-table (cons (list name proc help) command-table))))286 (##sys#void))287288(define default-evaluator289 (let ((eval eval)290 (load-noisily load-noisily)291 (read (lambda () (chicken.syntax#read-with-source-info (current-input-port)))) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing292 (read-line read-line)293 (display display)294 (string-split string-split)295 (printf printf)296 (expand expand)297 (pretty-print pretty-print)298 (values values) )299 (lambda (form)300 (cond ((eof-object? form) (quit))301 ((and (pair? form)302 (eq? 'unquote (##sys#slot form 0)) )303 (let ((cmd (cadr form)))304 (cond ((assq cmd command-table) =>305 (lambda (p)306 ((cadr p))307 (##sys#void) ) )308 (else309 ;;XXX use `toplevel-command' to define as many as possible of these310 (case cmd311 ((x)312 (let ([x (read)])313 (pretty-print (strip-syntax (expand x)))314 (##sys#void) ) )315 ((p)316 (let* ([x (read)]317 [xe (eval x)] )318 (pretty-print xe)319 (##sys#void) ) )320 ((d)321 (let* ([x (read)]322 [xe (eval x)] )323 (describe xe) ) )324 ((du)325 (let* ([x (read)]326 [xe (eval x)] )327 (dump xe) ) )328 ((dur)329 (let* ([x (read)]330 [n (read)]331 [xe (eval x)]332 [xn (eval n)] )333 (dump xe xn) ) )334 ((r) (report))335 ((q) (quit))336 ((l)337 (let ((fns (string-split (read-line))))338 (for-each load fns)339 (##sys#void) ) )340 ((ln)341 (let ((fns (string-split (read-line))))342 (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)343 (##sys#void) ) )344 ((t)345 (let ((x (read)))346 (receive rs (time (eval x))347 (history-add rs)348 (apply values rs) ) ) )349 ((exn)350 (when ##sys#last-exception351 (history-add (list ##sys#last-exception))352 (describe ##sys#last-exception) ) )353 ((e)354 (let ((r (system355 (string-append356 (or (editor-command) default-editor)357 " " (read-line)))))358 (if (not (zero? r))359 (printf "editor returned with non-zero exit status ~a" r))))360 ((ch)361 (history-clear)362 (##sys#void))363 ((h)364 (history-show)365 (##sys#void))366 ((c)367 (show-frameinfo selected-frame)368 (##sys#void))369 ((f)370 (select-frame (read))371 (##sys#void))372 ((g)373 (copy-from-frame (read)))374 ((s)375 (let* ((str (read-line))376 (r (system str)) )377 (history-add (list r))378 r) )379 ((?)380 (display381 "Toplevel commands:382383 ,? Show this text384 ,p EXP Pretty print evaluated expression EXP385 ,d EXP Describe result of evaluated expression EXP386 ,du EXP Dump data of expression EXP387 ,dur EXP N Dump range388 ,q Quit interpreter389 ,l FILENAME ... Load one or more files390 ,ln FILENAME ... Load one or more files and print result of each top-level expression391 ,r Show system information392 ,h Show history of expression results393 ,ch Clear history of expression results394 ,e FILENAME Run external editor395 ,s TEXT ... Execute shell-command396 ,exn Describe last exception397 ,c Show call-chain of most recent error398 ,f N Select frame N399 ,g NAME Get variable NAME from current frame400 ,t EXP Evaluate form and print elapsed time401 ,x EXP Pretty print expanded expression EXP\n")402 (for-each403 (lambda (a)404 (let ((help (caddr a)))405 (if help406 (print #\space help)407 (print " ," (car a)) ) ) )408 command-table)409 (##sys#void) )410 (else411 (printf "undefined toplevel command ~s - enter `,?' for help~%" form)412 (##sys#void) ) ) ) ) ) )413 (else414 (receive rs (eval form)415 (history-add rs)416 (apply values rs) ) ) ) ) ) )417418419;;; Builtin toplevel commands:420421(toplevel-command422 'm423 (let ((printf printf))424 (lambda ()425 (let ((name (read)))426 (cond ((not name)427 (##sys#switch-module #f)428 (printf "; resetting current module to toplevel~%"))429 ((##sys#find-module (##sys#resolve-module-name name #f) #f) =>430 (lambda (m)431 (##sys#switch-module m)432 (printf "; switching current module to `~a'~%" name)))433 (else434 (printf "undefined module `~a'~%" name))))))435 ",m MODULE switch to module with name `MODULE'")436437(toplevel-command438 'x1439 (let ((pretty-print pretty-print))440 (lambda ()441 (let ([expr (read)])442 ;; avoid bootstrapping issue, as chicken.syntax is not443 ;; imported dynamically by bootstrap compiler444 ;; this can be replaced by "expand1" later445 (pretty-print (strip-syntax (chicken.syntax#expand1 expr)))446 (##sys#void))))447 ",x1 EXP Pretty print expand1-ed expression EXP")448449450;;; Parse options from string:451452(define (parse-option-string str)453 (let ([ins (open-input-string str)])454 (map (lambda (o)455 (if (string? o)456 o457 (let ([os (open-output-string)])458 (write o os)459 (get-output-string os) ) ) )460 (handle-exceptions ex (##sys#error "invalid option syntax" str)461 (do ([x (read ins) (read ins)]462 [xs '() (cons x xs)] )463 ((eof-object? x) (reverse xs)) ) ) ) ) )464465466;;; Print status information:467468(define report469 (let ((printf printf)470 (sort sort)471 (with-output-to-port with-output-to-port)472 (current-output-port current-output-port)473 (argv argv)474 (prefix (foreign-value "C_INSTALL_PREFIX" c-string)))475 (lambda port476 (with-output-to-port (if (pair? port) (car port) (current-output-port))477 (lambda ()478 (gc)479 (let ((sinfo (##sys#symbol-table-info))480 (minfo (memory-statistics))481 (interrupts (foreign-value "C_interrupts_enabled" bool))482 (fixed-heap (foreign-value "C_heap_size_is_fixed" bool))483 (downward-stack (foreign-value "C_STACK_GROWS_DOWNWARD" bool)))484 (define (shorten n) (/ (truncate (* n 100)) 100))485 (printf "Features:~%~%")486 (let ((fs (sort (map keyword->string ##sys#features) string<?))487 (c 0))488 (for-each489 (lambda (f)490 (printf " ~a" f)491 (let* ((len (string-length f))492 (pad (- 16 len)))493 (set! c (add1 c))494 (when (<= pad 0)495 (set! c (add1 c))496 (set! pad (+ pad 18)))497 (cond ((>= c 3)498 (display "\n")499 (set! c 0))500 (else501 (display (make-string pad #\space))))))502 fs))503 (printf "~%~%~504 Machine type: \t~A (~A-bit)~%~505 Software type: \t~A~%~506 Software version:\t~A~%~507 Build platform: \t~A~%~508 Installation prefix:\t~A~%~509 Extension installation location:\t~A~%~510 Extension path: \t~A~%~511 Include path: \t~A~%~512 Keyword style: \t~A~%~513 Symbol-table load:\t~S~% ~514 Avg bucket length:\t~S~% ~515 Total symbol count:\t~S~%~516 Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~517 nursery size is ~S bytes, stack grows ~A~%~518 Command line: \t~S~%"519 (machine-type)520 (foreign-value "C_WORD_SIZE" int)521 (software-type)522 (software-version)523 (build-platform)524 prefix525 (installation-repository)526 (repository-path)527 ##sys#include-pathnames528 (keyword->string (keyword-style))529 (shorten (vector-ref sinfo 0))530 (shorten (vector-ref sinfo 1))531 (vector-ref sinfo 2)532 (vector-ref minfo 0)533 (if fixed-heap " (fixed)" "")534 (vector-ref minfo 1)535 (vector-ref minfo 2)536 (if downward-stack "downward" "upward")537 (argv))538 (##sys#write-char-0 #\newline ##sys#standard-output)539 (when interrupts (display "interrupts are enabled\n"))540 (##core#undefined) ) ) ) ) ) )541542543;;; Describe & dump:544545(define bytevector-data546 '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)547 (s8vector "vector of signed bytes" s8vector-length s8vector-ref)548 (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)549 (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)550 (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)551 (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)552 (u64vector "vector of unsigned 64-bit words" u64vector-length u64vector-ref)553 (s64vector "vector of signed 64-bit words" s64vector-length s64vector-ref)554 (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)555 (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref)556 (c64vector "vector of 32-bit complex numbers" c64vector-length c64vector-ref)557 (c128vector "vector of 64-bit complex numbers" c128vector-length c128vector-ref) ) )558559(define (circular-list? x)560 (let lp ((x x) (lag x))561 (and (pair? x)562 (let ((x (cdr x)))563 (and (pair? x)564 (let ((x (cdr x))565 (lag (cdr lag)))566 (or (eq? x lag) (lp x lag))))))))567568(define (improper-pairs? x)569 (let lp ((x x))570 (if (not (pair? x)) #f571 (or (eq? x (car x))572 (lp (cdr x))))))573574(define-constant max-describe-lines 40)575576(define describe577 (let ([sprintf sprintf]578 [printf printf]579 [fprintf fprintf]580 [length length]581 [list-ref list-ref]582 [string-ref string-ref])583 (lambda (x #!optional (out ##sys#standard-output))584 (define (descseq name plen pref start)585 (let ((len (fx- (plen x) start)))586 (when name (fprintf out "~A of length ~S~%" name len))587 (let loop1 ((i 0))588 (cond ((fx>= i len))589 ((fx>= i max-describe-lines)590 (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )591 (else592 (let ((v (pref x (fx+ start i))))593 (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))594 (cond ((fx>= j len)595 (##sys#with-print-length-limit596 1000597 (lambda ()598 (fprintf out " ~S: ~S" i v)))599 (if (fx> n 1)600 (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"601 (fx- n 1)602 (if (eq? n 2) "" "s"))603 (newline out) )604 (loop1 (fx+ i n)) )605 ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))606 (else (loop2 n len)) ) ) ) ) ) ) ) )607 (when (##sys#permanent? x)608 (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )609 (cond ((char? x)610 (let ([code (char->integer x)])611 (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) )612 ((eq? x #t) (fprintf out "boolean true~%"))613 ((eq? x #f) (fprintf out "boolean false~%"))614 ((null? x) (fprintf out "empty list~%"))615 ((bwp-object? x)616 (fprintf out "broken weak pointer~%"))617 ((eof-object? x) (fprintf out "end-of-file object~%"))618 ((eq? (##sys#void) x) (fprintf out "unspecified object~%"))619 ((fixnum? x)620 (fprintf out "exact immediate integer ~S~% #x~X~% #o~O~% #b~B"621 x x x x)622 (let ([code (integer->char x)])623 (when (fx< x #x10000) (fprintf out ", character ~S" code)) )624 (##sys#write-char-0 #\newline ##sys#standard-output) )625 ((bignum? x)626 (fprintf out "exact large integer ~S~% #x~X~% #o~O~% #b~B~%"627 x x x x) )628 ((##core#inline "C_unboundvaluep" x)629 (fprintf out "unbound value~%"))630 ((flonum? x) (fprintf out "inexact rational number ~S~%" x))631 ((ratnum? x) (fprintf out "exact ratio ~S~%" x))632 ((cplxnum? x) (fprintf out "~A complex number ~S~%"633 (if (exact? x) "exact" "inexact") x))634 ((number? x) (fprintf out "number ~S~%" x))635 ((string? x) (descseq "string" string-length string-ref 0))636 ((vector? x) (descseq "vector" ##sys#size ##sys#slot 0))637 ((keyword? x)638 (fprintf out "keyword symbol with name ~s~%"639 (##sys#symbol->string/shared x)))640 ((symbol? x)641 (unless (##sys#symbol-has-toplevel-binding? x)642 (display "unbound " out))643 (fprintf out "~asymbol with name ~S~%"644 (if (##sys#interned-symbol? x) "" "uninterned ")645 (##sys#symbol->string/shared x))646 (let ((plist (##sys#slot x 2)))647 (unless (null? plist)648 (display " \nproperties:\n\n" out)649 (do ((plist plist (cddr plist)))650 ((null? plist))651 (fprintf out " ~s\t" (car plist))652 (##sys#with-print-length-limit653 1000654 (lambda ()655 (write (cadr plist) out) ) )656 (newline out) ) ) ) )657 ((or (circular-list? x) (improper-pairs? x))658 (fprintf out "circular structure: ")659 (let loop-print ((x x)660 (cdr-refs (list x)))661 (cond ((or (atom? x)662 (null? x)) (printf "eol~%"))663 ((memq (car x) cdr-refs)664 (fprintf out "(circle)~%" ))665 ((not (memq (car x) cdr-refs))666 (fprintf out "~S -> " (car x))667 (loop-print (cdr x) (cons (car x) cdr-refs) )))))668 ((list? x) (descseq "list" length list-ref 0))669 ((pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x)))670 ((procedure? x)671 (let ([len (##sys#size x)])672 (descseq673 (sprintf "procedure with code pointer 0x~X" (##sys#peek-unsigned-integer x 0))674 ##sys#size ##sys#slot 1) ) )675 ((port? x)676 (fprintf out677 "~A port of type ~A with name ~S and ~A encoding~%"678 (if (##sys#slot x 1) "input" "output")679 (##sys#slot x 7)680 (##sys#slot x 3)681 (##sys#slot x 15) ) )682 ((not (##core#inline "C_blockp" x))683 ;; catch immediates here, as ##sys#locative? crashes on non-block684 (fprintf out "unknown immediate object~%"))685 ((##sys#locative? x)686 (fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"687 (##sys#peek-unsigned-integer x 0)688 (##sys#slot x 1)689 (case (##sys#slot x 2)690 ((0) "slot")691 ((1) "char")692 ((2) "u8vector")693 ((3) "s8vector")694 ((4) "u16vector")695 ((5) "s16vector")696 ((6) "u32vector")697 ((7) "s32vector")698 ((8) "u64vector")699 ((9) "s64vector")700 ((10) "f32vector")701 ((11) "f64vector") ) ) )702 ((##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0)))703 ((##sys#bytevector? x)704 (let ([len (##sys#size x)])705 (fprintf out "bytevector of size ~S:~%" len)706 (hexdump x len ##sys#byte out) ) )707 ((##core#inline "C_lambdainfop" x)708 (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) )709 ((##sys#structure? x 'hash-table)710 (let ((n (##sys#slot x 2)))711 (fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"712 n (if (fx= n 1) "" "s") (##sys#slot x 3)) )713 (fprintf out " hash function: ~a~%" (##sys#slot x 4))714 ;; this copies code out of srfi-69.scm, but we don't want to depend on it715 (let* ((vec (##sys#slot x 1))716 (len (##sys#size vec)) )717 (do ((i 0 (fx+ i 1)) )718 ((fx>= i len))719 (for-each720 (lambda (bucket)721 (fprintf out " ~S\t-> ~S~%"722 (##sys#slot bucket 0) (##sys#slot bucket 1)) )723 (##sys#slot vec i)) ) ) )724 ((##sys#structure? x 'condition)725 (fprintf out "condition: ~s~%" (##sys#slot x 1))726 (for-each727 (lambda (k)728 (fprintf out " ~s~%" k)729 (let loop ((props (##sys#slot x 2)))730 (unless (null? props)731 (when (eq? k (caar props))732 (##sys#with-print-length-limit733 100734 (lambda ()735 (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))736 (newline out))737 (loop (cddr props)) ) ) )738 (##sys#slot x 1) ) )739 ((##sys#generic-structure? x)740 (let ((st (##sys#slot x 0)))741 (cond ((assq st bytevector-data) =>742 (lambda (data)743 (apply descseq (append (map eval (cdr data)) (list 0)))) )744 (else745 (fprintf out "structure of type `~S':~%" (##sys#slot x 0))746 (descseq #f ##sys#size ##sys#slot 1) ) ) ) )747 (else (fprintf out "unknown object~%")) )748 (##sys#void) ) ) )749750751;;; Display hexdump:752753(define dump754 (lambda (x . len-out)755 (let-optionals len-out756 ([len #f]757 [out ##sys#standard-output] )758 (define (bestlen n) (if len (min len n) n))759 (cond [(##sys#immediate? x) (##sys#error 'dump "cannot dump immediate object" x)]760 [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]761 [(string? x)762 (let ((bv (##sys#slot x 0)))763 (hexdump bv (bestlen (fx- (##sys#size bv) 1)) ##sys#byte out))]764 [(and (not (##sys#immediate? x)) (##sys#pointer? x))765 (hexdump x 32 ##sys#peek-byte out) ]766 [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))767 (let ([bv (##sys#slot x 1)])768 (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]769 [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )770771(define hexdump772 (let ([display display]773 [string-append string-append]774 [make-string make-string]775 [write-char write-char] )776 (lambda (bv len ref out)777778 (define (justify n m base lead)779 (let* ([s (number->string n base)]780 [len (string-length s)] )781 (if (fx< len m)782 (string-append (make-string (fx- m len) lead) s)783 s) ) )784785 (do ([a 0 (fx+ a 16)])786 ((fx>= a len))787 (display (justify a 4 10 #\space) out)788 (write-char #\: out)789 (do ([j 0 (fx+ j 1)]790 [a a (fx+ a 1)] )791 ((or (fx>= j 16) (fx>= a len))792 (when (fx>= a len)793 (let ((o (fxmod len 16)))794 (unless (fx= o 0)795 (do ((k (fx- 16 o) (fx- k 1)))796 ((fx= k 0))797 (display " " out) ) ) ) ) )798 (write-char #\space out)799 (display (justify (ref bv a) 2 16 #\0) out) )800 (write-char #\space out)801 (do ([j 0 (fx+ j 1)]802 [a a (fx+ a 1)] )803 ((or (fx>= j 16) (fx>= a len)))804 (let ([c (ref bv a)])805 (if (and (fx>= c 32) (fx< c 128))806 (write-char (integer->char c) out)807 (write-char #\. out) ) ) )808 (write-char #\newline out) ) ) ) )809810811;;; Frame-info operations:812813(define show-frameinfo814 (let ((newline newline)815 (display display))816 (lambda (fn)817 (define (prin1 x)818 (##sys#with-print-length-limit819 100820 (lambda ()821 (##sys#print x #t ##sys#standard-output))))822 (let* ((ct (or ##sys#repl-recent-call-chain '()))823 (len (length ct)))824 (set! selected-frame825 (or (and (memq fn ct) fn)826 (and (fx> len 0)827 (list-ref ct (fx- len 1)))))828 (do ((ct ct (cdr ct))829 (i (fx- len 1) (fx- i 1)))830 ((null? ct))831 (let* ((info (car ct))832 (here (eq? selected-frame info))833 (form (##sys#slot info 1)) ; cooked1 (expr/form)834 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)835 (finfo (##sys#structure? data 'frameinfo))836 (cntr (if finfo (##sys#slot data 1) data))) ; cntr837 (printf "~a~a:~a\t~a\t "838 (if here #\* #\space)839 i840 (if (and finfo (pair? (##sys#slot data 2))) "[]" " ") ; e841 (##sys#slot info 0)) ; raw842 (when cntr (printf "[~a] " cntr))843 (when form (prin1 form))844 (newline)845 (when (and here finfo)846 (for-each847 (lambda (e v)848 (unless (null? e)849 (display " ---\n")850 (do ((i 0 (fx+ i 1))851 (be e (cdr be)))852 ((null? be))853 (printf " ~s:\t " (car be))854 (prin1 (##sys#slot v i))855 (newline))))856 (##sys#slot data 2) ; e857 (##sys#slot data 3))))))))) ; v858859(define select-frame860 (let ((display display))861 (lambda (n)862 (cond ((or (not (number? n))863 (not ##sys#repl-recent-call-chain)864 (fx< n 0)865 (fx>= n (length ##sys#repl-recent-call-chain)))866 (display "no such frame\n"))867 (else868 (set! selected-frame869 (list-ref870 ##sys#repl-recent-call-chain871 (fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))872 (show-frameinfo selected-frame))))))873874(define copy-from-frame875 (let ((display display)876 (newline newline)877 (call/cc call-with-current-continuation))878 (lambda (name)879 (let* ((ct (or ##sys#repl-recent-call-chain '()))880 (len (length ct))881 (name882 (cond ((symbol? name) (##sys#slot name 1)) ; name883 ((string? name) name)884 (else885 (display "string or symbol required for `,g'\n")886 #f))))887 (define (compare sym)888 (let ((str (##sys#slot sym 1))) ; name889 (string=?890 name891 (substring str 0 (min (string-length name) (string-length str))))))892 (if name893 (call/cc894 (lambda (return)895 (define (fail msg)896 (display msg)897 (newline)898 (return (##sys#void)))899 (do ((ct ct (cdr ct)))900 ((null? ct) (fail "no environment in frame"))901 ;;XXX this should be refactored as it duplicates the code above902 (let* ((info (car ct))903 (here (eq? selected-frame info))904 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)905 (finfo (##sys#structure? data 'frameinfo)))906 (when (and here finfo)907 (for-each908 (lambda (e v)909 (do ((i 0 (fx+ i 1))910 (be e (cdr be)))911 ((null? be))912 (when (compare (car be))913 (display "; getting ")914 (display (car be))915 (newline)916 (history-add (list (##sys#slot v i)))917 (return (##sys#slot v i)))))918 (##sys#slot data 2) ; e919 (##sys#slot data 3)) ; v920 (fail (##sys#string-append "no such variable: " name)))))))921 (##sys#void))))))922923924;;; Handle some signals:925926(define-foreign-variable _sigint int "SIGINT")927928(define-syntax defhandler929 (syntax-rules ()930 ((_ sig handler)931 (begin932 (##core#inline "C_establish_signal_handler" sig sig)933 (##sys#setslot ##sys#signal-vector sig handler)))))934935(defhandler _sigint (lambda (n) (##sys#user-interrupt-hook)))936937938;;; Start interpreting:939940(define (member* keys set)941 (let loop ((set set))942 (and (pair? set)943 (let find ((ks keys))944 (cond ((null? ks) (loop (cdr set)))945 ((equal? (car ks) (car set)) set)946 (else (find (cdr ks))) ) ) ) ) )947948(define-constant short-options949 '(#\k #\s #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P #\K) )950951(define-constant long-options952 '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-no-feature" "-eval"953 "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"954 "-r7rs-syntax" "-setup-mode"955 "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"956 "-include-path" "-release" "-print" "-pretty-print" "--") )957958(define (canonicalize-args args)959 (let loop ((args args))960 (if (null? args)961 '()962 (let ((x (car args)))963 (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)964 ((and (fx= (string-length x) 2)965 (char=? #\- (string-ref x 0)))966 (if (memq (string-ref x 1) short-options)967 (cons x (loop (cdr args)))968 (##sys#error "invalid option" x)))969 ((and (fx> (string-length x) 2)970 (char=? #\- (string-ref x 0))971 (not (member x long-options)) )972 (if (char=? #\: (string-ref x 1))973 (loop (cdr args))974 (let ((cs (string->list (substring x 1))))975 (if (findall cs short-options)976 (append (map (cut string #\- <>) cs) (loop (cdr args)))977 (##sys#error "invalid option" x) ) ) ) )978 (else (cons x (loop (cdr args)))))))))979980(define (findall chars clist)981 (let loop ((chars chars))982 (or (null? chars)983 (and (memq (car chars) clist)984 (loop (cdr chars))))))985986(define-constant simple-options987 '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"988 "-i" "-case-insensitive"989 "-no-parentheses-synonyms" "-r7rs-syntax" "-setup-mode"990 ; Not "simple" but processed early991 "-ss" "-sx" "-s" "-script") )992993(define-constant complex-options994 '("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )995996(define (string-trim str)997 (let loop ((front 0)998 (back (string-length str)))999 (cond ((= front back) "")1000 ((char-whitespace? (string-ref str front))1001 (loop (add1 front) back))1002 ((char-whitespace? (string-ref str (sub1 back)))1003 (loop front (sub1 back)))1004 (else (substring str front back)))))10051006(define (string->extension-name str)1007 (let ((str (string-trim str)))1008 (if (and (positive? (string-length str))1009 (char=? #\( (string-ref str 0)))1010 (handle-exceptions ex1011 (##sys#error "invalid import specification" str)1012 (with-input-from-string str read))1013 (string->symbol str))))10141015(define (run)1016 (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]1017 [args (canonicalize-args (command-line-arguments))]1018 ; Check for these before 'args' is updated by any 'extraopts'1019 [kwstyle (member* '("-K" "-keyword-style") args)]1020 [script (member* '("-ss" "-sx" "-s" "-script") args)])1021 (cond [script1022 (when (or (not (pair? (cdr script)))1023 (zero? (string-length (cadr script)))1024 (char=? #\- (string-ref (cadr script) 0)) )1025 (##sys#error "missing or invalid script argument"))1026 (program-name (cadr script))1027 (command-line-arguments (cddr script))1028 ;; 2012-10-04 (felix) left 'script activated to avoid breaking too much code1029 (register-feature! 'chicken-script)1030 (set-cdr! (cdr script) '())1031 (when ##sys#windows-platform1032 (and-let* ((sname (lookup-script-file (cadr script))))1033 (set-car! (cdr script) sname) ) ) ]1034 [else1035 (set! args (append (canonicalize-args extraopts) args))1036 (and-let* ([p (member "--" args)])1037 (set-cdr! p '()) ) ] )1038 (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]1039 [batch (or script (member* '("-b" "-batch") args) eval?)]1040 [quietflag (member* '("-q" "-quiet") args)]1041 [quiet (or script quietflag eval?)])1042 (define (collect-options opt)1043 (let loop ([opts args])1044 (cond [(member opt opts)1045 => (lambda (p)1046 (if (null? (cdr p))1047 (##sys#error "missing argument to command-line option" opt)1048 (cons (cadr p) (loop (cddr p)))) ) ]1049 [else '()] ) ) )1050 (define (loadinit)1051 (let* ((sys-dir (system-config-directory))1052 (cfg-fn (and sys-dir (make-pathname (list sys-dir "chicken")1053 init-file)))1054 (home (get-environment-variable "HOME"))1055 (home-fn (and home (not (string=? home ""))1056 (make-pathname home (string-append "." init-file)))))1057 (cond ((and cfg-fn (file-exists? cfg-fn))1058 (load cfg-fn))1059 ((and home-fn (file-exists? home-fn))1060 (load home-fn) ) ) ) )1061 (define (evalstring str #!optional (rec (lambda _ (void))))1062 (let ((in (open-input-string str))1063 (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing1064 (do ([x (read-with-source-info in) (read-with-source-info in)])1065 ((eof-object? x))1066 (rec (receive (eval x))) ) ) )1067 (when (member* '("-h" "-help" "--help") args)1068 (print-usage)1069 (exit 0) )1070 (when (member "-version" args)1071 (print-banner)1072 (exit 0) )1073 (when (member "-setup-mode" args)1074 (set! ##sys#setup-mode #t))1075 (when (member "-release" args)1076 (print (chicken-version))1077 (exit 0) )1078 (when (member* '("-w" "-no-warnings") args)1079 (unless quiet (display "Warnings are disabled\n"))1080 (set! ##sys#warnings-enabled #f) )1081 (when (member* '("-i" "-case-insensitive") args)1082 (unless quiet (display "Identifiers and symbols are case insensitive\n"))1083 (register-feature! 'case-insensitive)1084 (case-sensitive #f) )1085 (for-each register-feature! (collect-options "-feature"))1086 (for-each register-feature! (collect-options "-D"))1087 (for-each unregister-feature! (collect-options "-no-feature"))1088 (set! ##sys#include-pathnames1089 (delete-duplicates1090 (append (map chop-separator (collect-options "-include-path"))1091 (map chop-separator (collect-options "-I"))1092 ##sys#include-pathnames)1093 string=?) )1094 (when kwstyle1095 (cond [(not (pair? (cdr kwstyle)))1096 (##sys#error "missing argument to `-keyword-style' option") ]1097 [(string=? "prefix" (cadr kwstyle))1098 (keyword-style #:prefix) ]1099 [(string=? "none" (cadr kwstyle))1100 (keyword-style #:none) ]1101 [(string=? "suffix" (cadr kwstyle))1102 (keyword-style #:suffix) ] ) )1103 (when (member* '("-no-parentheses-synonyms") args)1104 (unless quiet (display "Disabled support for parentheses synonyms\n"))1105 (parentheses-synonyms #f) )1106 (when (member* '("-r7rs-syntax") args)1107 (unless quiet (display "Disabled the CHICKEN extensions to R7RS syntax\n"))1108 (case-sensitive #f)1109 (keyword-style #:none)1110 (parentheses-synonyms #f) )1111 ;; Load the the default modules into the evaluation environment.1112 ;; This is done before setting load-verbose => #t to avoid1113 ;; spurious import messages.1114 (eval `(import-for-syntax ,@default-syntax-imports))1115 (eval `(import ,@default-imports))1116 (unless quiet1117 (load-verbose #t)1118 (print-banner)1119 (print "Type ,? for help."))1120 (unless (or (member* '("-n" "-no-init") args) script eval?)1121 (loadinit))1122 (when batch1123 (set! ##sys#notices-enabled #f))1124 (do ([args args (cdr args)])1125 ((null? args)1126 (register-repl-history!)1127 (unless batch1128 (repl default-evaluator)1129 (##sys#write-char-0 #\newline ##sys#standard-output) ) )1130 (let* ((arg (car args)))1131 (cond ((member arg simple-options))1132 ((member arg complex-options)1133 (set! args (cdr args)) )1134 ((or (string=? "-R" arg) (string=? "-require-extension" arg))1135 (eval `(import ,(string->extension-name (cadr args))))1136 (set! args (cdr args)) )1137 ((or (string=? "-e" arg) (string=? "-eval" arg))1138 (evalstring (cadr args))1139 (set! args (cdr args)) )1140 ((or (string=? "-p" arg) (string=? "-print" arg))1141 (evalstring (cadr args) (cut for-each print <...>))1142 (set! args (cdr args)) )1143 ((or (string=? "-P" arg) (string=? "-pretty-print" arg))1144 (evalstring (cadr args) (cut for-each pretty-print <...>) )1145 (set! args (cdr args)) )1146 (else1147 (let ((scr (and script (car script))))1148 (load1149 arg1150 (and (equal? "-sx" scr)1151 (lambda (x)1152 (let* ((str (with-output-to-string (cut pretty-print x)))1153 (len (string-length str)))1154 (flush-output ##sys#standard-output)1155 (display "\n; " ##sys#standard-error)1156 (do ((i 0 (fx+ i 1)))1157 ((fx>= i len))1158 (let ((c (string-ref str i)))1159 (write-char c ##sys#standard-error)1160 (when (char=? #\newline c)1161 (display "; " ##sys#standard-error))))1162 (newline ##sys#standard-error)1163 (eval x)))))1164 (when (equal? "-ss" scr)1165 (receive rs ((eval 'main) (command-line-arguments))1166 (let ((r (optional rs)))1167 (exit (if (fixnum? r) r 0)))))))))))))11681169(run))