~ chicken-core (chicken-5) /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 set-describer! 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(include "banner.scm")71(include "mini-srfi-1.scm")7273;;; Parameters:7475(define-constant init-file "csirc")7677(set! ##sys#repl-print-length-limit 2048)78(set! ##sys#features (cons #:csi ##sys#features))79(set! ##sys#notices-enabled #t)8081(define editor-command (make-parameter #f))82(define selected-frame #f)8384(define default-editor85 (or (get-environment-variable "EDITOR")86 (get-environment-variable "VISUAL")87 (if (get-environment-variable "EMACS")88 "emacsclient"89 "vi"))) ; shudder909192;;; Print all sorts of information:9394(define (print-usage)95 (display #<<EOF96usage: csi [OPTION ...] [FILENAME ...]9798 `csi' is the CHICKEN interpreter.99100 FILENAME is a Scheme source file name with optional extension. OPTION may be101 one of the following:102103 -h -help display this text and exit104 -version display version and exit105 -release print release number and exit106 -i -case-insensitive enable case-insensitive reading107 -e -eval EXPRESSION evaluate given expression108 -p -print EXPRESSION evaluate and print result(s)109 -P -pretty-print EXPRESSION evaluate and print result(s) prettily110 -D -feature SYMBOL register feature identifier111 -no-feature SYMBOL disable built-in feature identifier112 -q -quiet do not print banner113114EOF115)116 (display #<#EOF117 -n -no-init do not load initialization file #{#\`} #{init-file} #{#\'}118119EOF120)121 (display #<<EOF122 -b -batch terminate after command-line processing123 -w -no-warnings disable all warnings124 -K -keyword-style STYLE enable alternative keyword-syntax125 (prefix, suffix or none)126 -no-parentheses-synonyms disables list delimiter synonyms127 -no-symbol-escape disables support for escaped symbols128 -r5rs-syntax disables the CHICKEN extensions to129 R5RS syntax130 -s -script PATHNAME use csi as interpreter for Scheme scripts131 -ss PATHNAME same as `-s', but invoke `main' procedure132 -sx PATHNAME same as `-s', but print each expression133 as it is evaluated134 -setup-mode prefer the current directory when locating extensions135 -R -require-extension NAME require extension and import before136 executing code137 -I -include-path PATHNAME add PATHNAME to include path138 -- ignore all following options139140EOF141) ) ;| <--- for emacs font-lock142143(define (print-banner)144 (print +banner+ (chicken-version #t) "\n"))145146147;;; Chop terminating separator from pathname:148149(define (dirseparator? c)150 (or (and ##sys#windows-platform (char=? c #\\))151 (char=? c #\/)))152153(define chop-separator154 (let ([substring substring] )155 (lambda (str)156 (let* ((len (sub1 (##sys#size str)))157 (c (string-ref str len)))158 (if (and (fx> len 0) (dirseparator? c))159 (substring str 0 len)160 str) ) ) ) )161162163;;; Find script in PATH (only used for Windows/DOS):164165(define lookup-script-file166 (let* ([buf (make-string 256)]167 [_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )168 (define (addext name)169 (if (file-exists? name)170 name171 (let ([n2 (string-append name ".bat")])172 (and (file-exists? n2) n2) ) ) )173 (define (string-index proc str1)174 (let ((len (##sys#size str1)))175 (let loop ((i 0))176 (cond ((fx>= i len) #f)177 ((proc (##core#inline "C_subchar" str1 i)) i)178 (else (loop (fx+ i 1))) ) ) ) )179 (lambda (name)180 (let ([path (get-environment-variable "PATH")])181 (and (> (##sys#size name) 0)182 (cond [(dirseparator? (string-ref name 0)) (addext name)]183 [(string-index dirseparator? name)184 (let ((p (_getcwd buf 256)))185 (addext (string-append (chop-separator p) "/" name)) ) ]186 [(addext name)]187 [else188 (let ([name2 (string-append "/" name)])189 (let loop ((ps (##sys#split-path path)))190 (and (pair? ps)191 (let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])192 (or (addext name2)193 (loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )194195196197;;; REPL history references:198199(define history-list (make-vector 32))200(define history-count 1)201202(define history-add203 (let ([vector-resize vector-resize])204 (lambda (vals)205 (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]206 [size (##sys#size history-list)] )207 (when (fx>= history-count size)208 (set! history-list (vector-resize history-list (fx* 2 size))) )209 (vector-set! history-list history-count x)210 (set! history-count (fx+ history-count 1))211 x) ) ) )212213(define (history-clear)214 (vector-fill! history-list (##sys#void)))215216(define history-show217 (let ((newline newline))218 (lambda ()219 (do ((i 1 (fx+ i 1)))220 ((>= i history-count))221 (printf "#~a: " i)222 (##sys#with-print-length-limit223 80224 (lambda ()225 (##sys#print (vector-ref history-list i) #t ##sys#standard-output)))226 (newline)))))227228(define (history-ref index)229 (let ([i (inexact->exact index)])230 (if (and (fx> i 0) (fx<= i history-count))231 (vector-ref history-list i)232 (##sys#error "history entry index out of range" index) ) ) )233234;;; Reader hooks for REPL history:235236(define (register-repl-history!)237 (set! ##sys#user-read-hook238 (let ((old-hook ##sys#user-read-hook))239 (lambda (char port)240 (cond ((or (char=? #\) char) (char-whitespace? char))241 `',(history-ref (fx- history-count 1)))242 (else (old-hook char port))))))243 (set! ##sys#sharp-number-hook244 (lambda (port n) `',(history-ref n))))245246(repl-prompt247 (let ((sprintf sprintf))248 (lambda ()249 (sprintf "#;~A~A> "250 (let ((m (##sys#current-module)))251 (if m252 (sprintf "~a:" (##sys#module-name m))253 ""))254 history-count))))255256257;;; Other REPL customizations:258259(define (tty-input?)260 (or (##core#inline "C_i_tty_forcedp")261 (##sys#tty-port? ##sys#standard-input)))262263(set! ##sys#read-prompt-hook264 (let ([old ##sys#read-prompt-hook])265 (lambda ()266 (when (tty-input?) (old)) ) ) )267268(define command-table '())269270(define (toplevel-command name proc #!optional help)271 (##sys#check-symbol name 'toplevel-command)272 (when help (##sys#check-string help 'toplevel-command))273 (cond ((assq name command-table) =>274 (lambda (a)275 (set-cdr! a (list proc help)) ))276 (else277 (set! command-table (cons (list name proc help) command-table))))278 (##sys#void))279280(define default-evaluator281 (let ((eval eval)282 (load-noisily load-noisily)283 (read (lambda () (chicken.syntax#read-with-source-info (current-input-port)))) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing284 (read-line read-line)285 (display display)286 (string-split string-split)287 (printf printf)288 (expand expand)289 (pretty-print pretty-print)290 (values values) )291 (lambda (form)292 (cond ((eof-object? form) (quit))293 ((and (pair? form)294 (eq? 'unquote (##sys#slot form 0)) )295 (let ((cmd (cadr form)))296 (cond ((assq cmd command-table) =>297 (lambda (p)298 ((cadr p))299 (##sys#void) ) )300 (else301 ;;XXX use `toplevel-command' to define as many as possible of these302 (case cmd303 ((x)304 (let ([x (read)])305 (pretty-print (strip-syntax (expand x)))306 (##sys#void) ) )307 ((p)308 (let* ([x (read)]309 [xe (eval x)] )310 (pretty-print xe)311 (##sys#void) ) )312 ((d)313 (let* ([x (read)]314 [xe (eval x)] )315 (describe xe) ) )316 ((du)317 (let* ([x (read)]318 [xe (eval x)] )319 (dump xe) ) )320 ((dur)321 (let* ([x (read)]322 [n (read)]323 [xe (eval x)]324 [xn (eval n)] )325 (dump xe xn) ) )326 ((r) (report))327 ((q) (quit))328 ((l)329 (let ((fns (string-split (read-line))))330 (for-each load fns)331 (##sys#void) ) )332 ((ln)333 (let ((fns (string-split (read-line))))334 (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)335 (##sys#void) ) )336 ((t)337 (let ((x (read)))338 (receive rs (time (eval x))339 (history-add rs)340 (apply values rs) ) ) )341 ((exn)342 (when ##sys#last-exception343 (history-add (list ##sys#last-exception))344 (describe ##sys#last-exception) ) )345 ((e)346 (let ((r (system347 (string-append348 (or (editor-command) default-editor)349 " " (read-line)))))350 (if (not (zero? r))351 (printf "editor returned with non-zero exit status ~a" r))))352 ((ch)353 (history-clear)354 (##sys#void))355 ((h)356 (history-show)357 (##sys#void))358 ((c)359 (show-frameinfo selected-frame)360 (##sys#void))361 ((f)362 (select-frame (read))363 (##sys#void))364 ((g)365 (copy-from-frame (read)))366 ((s)367 (let* ((str (read-line))368 (r (system str)) )369 (history-add (list r))370 r) )371 ((?)372 (display373 "Toplevel commands:374375 ,? Show this text376 ,p EXP Pretty print evaluated expression EXP377 ,d EXP Describe result of evaluated expression EXP378 ,du EXP Dump data of expression EXP379 ,dur EXP N Dump range380 ,q Quit interpreter381 ,l FILENAME ... Load one or more files382 ,ln FILENAME ... Load one or more files and print result of each top-level expression383 ,r Show system information384 ,h Show history of expression results385 ,ch Clear history of expression results386 ,e FILENAME Run external editor387 ,s TEXT ... Execute shell-command388 ,exn Describe last exception389 ,c Show call-chain of most recent error390 ,f N Select frame N391 ,g NAME Get variable NAME from current frame392 ,t EXP Evaluate form and print elapsed time393 ,x EXP Pretty print expanded expression EXP\n")394 (for-each395 (lambda (a)396 (let ((help (caddr a)))397 (if help398 (print #\space help)399 (print " ," (car a)) ) ) )400 command-table)401 (##sys#void) )402 (else403 (printf "undefined toplevel command ~s - enter `,?' for help~%" form)404 (##sys#void) ) ) ) ) ) )405 (else406 (receive rs (eval form)407 (history-add rs)408 (apply values rs) ) ) ) ) ) )409410411;;; Builtin toplevel commands:412413(toplevel-command414 'm415 (let ((printf printf))416 (lambda ()417 (let ((name (read)))418 (cond ((not name)419 (##sys#switch-module #f)420 (printf "; resetting current module to toplevel~%"))421 ((##sys#find-module (##sys#resolve-module-name name #f) #f) =>422 (lambda (m)423 (##sys#switch-module m)424 (printf "; switching current module to `~a'~%" name)))425 (else426 (printf "undefined module `~a'~%" name))))))427 ",m MODULE switch to module with name `MODULE'")428429430;;; Parse options from string:431432(define (parse-option-string str)433 (let ([ins (open-input-string str)])434 (map (lambda (o)435 (if (string? o)436 o437 (let ([os (open-output-string)])438 (write o os)439 (get-output-string os) ) ) )440 (handle-exceptions ex (##sys#error "invalid option syntax" str)441 (do ([x (read ins) (read ins)]442 [xs '() (cons x xs)] )443 ((eof-object? x) (reverse xs)) ) ) ) ) )444445446;;; Print status information:447448(define report449 (let ((printf printf)450 (sort sort)451 (with-output-to-port with-output-to-port)452 (current-output-port current-output-port)453 (argv argv)454 (prefix (foreign-value "C_INSTALL_PREFIX" c-string)))455 (lambda port456 (with-output-to-port (if (pair? port) (car port) (current-output-port))457 (lambda ()458 (gc)459 (let ((sinfo (##sys#symbol-table-info))460 (minfo (memory-statistics))461 (interrupts (foreign-value "C_interrupts_enabled" bool))462 (fixed-heap (foreign-value "C_heap_size_is_fixed" bool))463 (downward-stack (foreign-value "C_STACK_GROWS_DOWNWARD" bool)))464 (define (shorten n) (/ (truncate (* n 100)) 100))465 (printf "Features:~%~%")466 (let ((fs (sort (map keyword->string ##sys#features) string<?))467 (c 0))468 (for-each469 (lambda (f)470 (printf " ~a" f)471 (let* ((len (string-length f))472 (pad (- 16 len)))473 (set! c (add1 c))474 (when (<= pad 0)475 (set! c (add1 c))476 (set! pad (+ pad 18)))477 (cond ((>= c 3)478 (display "\n")479 (set! c 0))480 (else481 (display (make-string pad #\space))))))482 fs))483 (printf "~%~%~484 Machine type: \t~A (~A-bit)~%~485 Software type: \t~A~%~486 Software version:\t~A~%~487 Build platform: \t~A~%~488 Installation prefix:\t~A~%~489 Extension installation location:\t~A~%~490 Extension path: \t~A~%~491 Include path: \t~A~%~492 Keyword style: \t~A~%~493 Symbol-table load:\t~S~% ~494 Avg bucket length:\t~S~% ~495 Total symbol count:\t~S~%~496 Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~497 nursery size is ~S bytes, stack grows ~A~%~498 Command line: \t~S~%"499 (machine-type)500 (foreign-value "C_WORD_SIZE" int)501 (software-type)502 (software-version)503 (build-platform)504 prefix505 (installation-repository)506 (repository-path)507 ##sys#include-pathnames508 (keyword->string (keyword-style))509 (shorten (vector-ref sinfo 0))510 (shorten (vector-ref sinfo 1))511 (vector-ref sinfo 2)512 (vector-ref minfo 0)513 (if fixed-heap " (fixed)" "")514 (vector-ref minfo 1)515 (vector-ref minfo 2)516 (if downward-stack "downward" "upward")517 (argv))518 (##sys#write-char-0 #\newline ##sys#standard-output)519 (when interrupts (display "interrupts are enabled\n"))520 (##core#undefined) ) ) ) ) ) )521522523;;; Describe & dump:524525(define bytevector-data526 '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)527 (s8vector "vector of signed bytes" s8vector-length s8vector-ref)528 (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)529 (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)530 (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)531 (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)532 (u64vector "vector of unsigned 64-bit words" u64vector-length u64vector-ref)533 (s64vector "vector of signed 64-bit words" s64vector-length s64vector-ref)534 (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)535 (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )536537(define (circular-list? x)538 (let lp ((x x) (lag x))539 (and (pair? x)540 (let ((x (cdr x)))541 (and (pair? x)542 (let ((x (cdr x))543 (lag (cdr lag)))544 (or (eq? x lag) (lp x lag))))))))545546(define (improper-pairs? x)547 (let lp ((x x))548 (if (not (pair? x)) #f549 (or (eq? x (car x))550 (lp (cdr x))))))551552(define-constant max-describe-lines 40)553554(define describer-table (make-vector 37 '()))555556(define describe557 (let ([sprintf sprintf]558 [printf printf]559 [fprintf fprintf]560 [length length]561 [list-ref list-ref]562 [string-ref string-ref])563 (lambda (x #!optional (out ##sys#standard-output))564 (define (descseq name plen pref start)565 (let ((len (fx- (plen x) start)))566 (when name (fprintf out "~A of length ~S~%" name len))567 (let loop1 ((i 0))568 (cond ((fx>= i len))569 ((fx>= i max-describe-lines)570 (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )571 (else572 (let ((v (pref x (fx+ start i))))573 (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))574 (cond ((fx>= j len)575 (##sys#with-print-length-limit576 1000577 (lambda ()578 (fprintf out " ~S: ~S" i v)))579 (if (fx> n 1)580 (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"581 (fx- n 1)582 (if (eq? n 2) "" "s"))583 (newline out) )584 (loop1 (fx+ i n)) )585 ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))586 (else (loop2 n len)) ) ) ) ) ) ) ) )587 (when (##sys#permanent? x)588 (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )589 (cond ((char? x)590 (let ([code (char->integer x)])591 (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) )592 ((eq? x #t) (fprintf out "boolean true~%"))593 ((eq? x #f) (fprintf out "boolean false~%"))594 ((null? x) (fprintf out "empty list~%"))595 ((##core#inline "C_bwpp" x)596 ;; TODO: replace with bwp-object? later597 (fprintf out "broken weak pointer~%"))598 ((eof-object? x) (fprintf out "end-of-file object~%"))599 ((eq? (##sys#void) x) (fprintf out "unspecified object~%"))600 ((fixnum? x)601 (fprintf out "exact immediate integer ~S~% #x~X~% #o~O~% #b~B"602 x x x x)603 (let ([code (integer->char x)])604 (when (fx< x #x10000) (fprintf out ", character ~S" code)) )605 (##sys#write-char-0 #\newline ##sys#standard-output) )606 ((bignum? x)607 (fprintf out "exact large integer ~S~% #x~X~% #o~O~% #b~B~%"608 x x x x) )609 ((##core#inline "C_unboundvaluep" x)610 (fprintf out "unbound value~%"))611 ((flonum? x) (fprintf out "inexact rational number ~S~%" x))612 ((ratnum? x) (fprintf out "exact ratio ~S~%" x))613 ((cplxnum? x) (fprintf out "~A complex number ~S~%"614 (if (exact? x) "exact" "inexact") x))615 ((number? x) (fprintf out "number ~S~%" x))616 ((string? x) (descseq "string" ##sys#size string-ref 0))617 ((vector? x) (descseq "vector" ##sys#size ##sys#slot 0))618 ((keyword? x)619 (fprintf out "keyword symbol with name ~s~%"620 (##sys#symbol->string x)))621 ((symbol? x)622 (unless (##sys#symbol-has-toplevel-binding? x)623 (display "unbound " out))624 (fprintf out "~asymbol with name ~S~%"625 (if (##sys#interned-symbol? x) "" "uninterned ")626 (##sys#symbol->string x))627 (let ((plist (##sys#slot x 2)))628 (unless (null? plist)629 (display " \nproperties:\n\n" out)630 (do ((plist plist (cddr plist)))631 ((null? plist))632 (fprintf out " ~s\t" (car plist))633 (##sys#with-print-length-limit634 1000635 (lambda ()636 (write (cadr plist) out) ) )637 (newline out) ) ) ) )638 ((or (circular-list? x) (improper-pairs? x))639 (fprintf out "circular structure: ")640 (let loop-print ((x x)641 (cdr-refs (list x)))642 (cond ((or (atom? x)643 (null? x)) (printf "eol~%"))644 ((memq (car x) cdr-refs)645 (fprintf out "(circle)~%" ))646 ((not (memq (car x) cdr-refs))647 (fprintf out "~S -> " (car x))648 (loop-print (cdr x) (cons (car x) cdr-refs) )))))649 ((list? x) (descseq "list" length list-ref 0))650 ((pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x)))651 ((procedure? x)652 (let ([len (##sys#size x)])653 (descseq654 (sprintf "procedure with code pointer 0x~X" (##sys#peek-unsigned-integer x 0))655 ##sys#size ##sys#slot 1) ) )656 ((port? x)657 (fprintf out658 "~A port of type ~A with name ~S and file pointer ~X~%"659 (if (##sys#slot x 1) "input" "output")660 (##sys#slot x 7)661 (##sys#slot x 3)662 (##sys#peek-unsigned-integer x 0) ) )663 ((not (##core#inline "C_blockp" x))664 ;; catch immediates here, as ##sys#locative? crashes on non-block665 (fprintf out "unknown immediate object~%"))666 ((##sys#locative? x)667 (fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"668 (##sys#peek-unsigned-integer x 0)669 (##sys#slot x 1)670 (case (##sys#slot x 2)671 ((0) "slot")672 ((1) "char")673 ((2) "u8vector")674 ((3) "s8vector")675 ((4) "u16vector")676 ((5) "s16vector")677 ((6) "u32vector")678 ((7) "s32vector")679 ((8) "u64vector")680 ((9) "s64vector")681 ((10) "f32vector")682 ((11) "f64vector") ) ) )683 ((##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0)))684 ((##sys#bytevector? x)685 (let ([len (##sys#size x)])686 (fprintf out "blob of size ~S:~%" len)687 (hexdump x len ##sys#byte out) ) )688 ((##core#inline "C_lambdainfop" x)689 (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) )690 ((##sys#structure? x 'hash-table)691 (let ((n (##sys#slot x 2)))692 (fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"693 n (if (fx= n 1) "" "s") (##sys#slot x 3)) )694 (fprintf out " hash function: ~a~%" (##sys#slot x 4))695 ;; this copies code out of srfi-69.scm, but we don't want to depend on it696 (let* ((vec (##sys#slot x 1))697 (len (##sys#size vec)) )698 (do ((i 0 (fx+ i 1)) )699 ((fx>= i len))700 (for-each701 (lambda (bucket)702 (fprintf out " ~S\t-> ~S~%"703 (##sys#slot bucket 0) (##sys#slot bucket 1)) )704 (##sys#slot vec i)) ) ) )705 ((##sys#structure? x 'condition)706 (fprintf out "condition: ~s~%" (##sys#slot x 1))707 (for-each708 (lambda (k)709 (fprintf out " ~s~%" k)710 (let loop ((props (##sys#slot x 2)))711 (unless (null? props)712 (when (eq? k (caar props))713 (##sys#with-print-length-limit714 100715 (lambda ()716 (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))717 (newline out))718 (loop (cddr props)) ) ) )719 (##sys#slot x 1) ) )720 ((##sys#generic-structure? x)721 (let ([st (##sys#slot x 0)])722 (cond ((hash-table-ref describer-table st) => (cut <> x out))723 ((assq st bytevector-data) =>724 (lambda (data)725 (apply descseq (append (map eval (cdr data)) (list 0)))) )726 (else727 (fprintf out "structure of type `~S':~%" (##sys#slot x 0))728 (descseq #f ##sys#size ##sys#slot 1) ) ) ) )729 (else (fprintf out "unknown object~%")) )730 (##sys#void) ) ) )731732(define (set-describer! tag proc)733 (##sys#check-symbol tag 'set-describer!)734 (hash-table-set! describer-table tag proc))735736737;;; Display hexdump:738739(define dump740 (lambda (x . len-out)741 (let-optionals len-out742 ([len #f]743 [out ##sys#standard-output] )744 (define (bestlen n) (if len (min len n) n))745 (cond [(##sys#immediate? x) (##sys#error 'dump "cannot dump immediate object" x)]746 [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]747 [(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]748 [(and (not (##sys#immediate? x)) (##sys#pointer? x))749 (hexdump x 32 ##sys#peek-byte out) ]750 [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))751 (let ([bv (##sys#slot x 1)])752 (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]753 [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )754755(define hexdump756 (let ([display display]757 [string-append string-append]758 [make-string make-string]759 [write-char write-char] )760 (lambda (bv len ref out)761762 (define (justify n m base lead)763 (let* ([s (number->string n base)]764 [len (##sys#size s)] )765 (if (fx< len m)766 (string-append (make-string (fx- m len) lead) s)767 s) ) )768769 (do ([a 0 (fx+ a 16)])770 ((fx>= a len))771 (display (justify a 4 10 #\space) out)772 (write-char #\: out)773 (do ([j 0 (fx+ j 1)]774 [a a (fx+ a 1)] )775 ((or (fx>= j 16) (fx>= a len))776 (when (fx>= a len)777 (let ((o (fxmod len 16)))778 (unless (fx= o 0)779 (do ((k (fx- 16 o) (fx- k 1)))780 ((fx= k 0))781 (display " " out) ) ) ) ) )782 (write-char #\space out)783 (display (justify (ref bv a) 2 16 #\0) out) )784 (write-char #\space out)785 (do ([j 0 (fx+ j 1)]786 [a a (fx+ a 1)] )787 ((or (fx>= j 16) (fx>= a len)))788 (let ([c (ref bv a)])789 (if (and (fx>= c 32) (fx< c 128))790 (write-char (integer->char c) out)791 (write-char #\. out) ) ) )792 (write-char #\newline out) ) ) ) )793794795;;; Frame-info operations:796797(define show-frameinfo798 (let ((newline newline)799 (display display))800 (lambda (fn)801 (define (prin1 x)802 (##sys#with-print-length-limit803 100804 (lambda ()805 (##sys#print x #t ##sys#standard-output))))806 (let* ((ct (or ##sys#repl-recent-call-chain '()))807 (len (length ct)))808 (set! selected-frame809 (or (and (memq fn ct) fn)810 (and (fx> len 0)811 (list-ref ct (fx- len 1)))))812 (do ((ct ct (cdr ct))813 (i (fx- len 1) (fx- i 1)))814 ((null? ct))815 (let* ((info (car ct))816 (here (eq? selected-frame info))817 (form (##sys#slot info 1)) ; cooked1 (expr/form)818 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)819 (finfo (##sys#structure? data 'frameinfo))820 (cntr (if finfo (##sys#slot data 1) data))) ; cntr821 (printf "~a~a:~a\t~a\t "822 (if here #\* #\space)823 i824 (if (and finfo (pair? (##sys#slot data 2))) "[]" " ") ; e825 (##sys#slot info 0)) ; raw826 (when cntr (printf "[~a] " cntr))827 (when form (prin1 form))828 (newline)829 (when (and here finfo)830 (for-each831 (lambda (e v)832 (unless (null? e)833 (display " ---\n")834 (do ((i 0 (fx+ i 1))835 (be e (cdr be)))836 ((null? be))837 (printf " ~s:\t " (car be))838 (prin1 (##sys#slot v i))839 (newline))))840 (##sys#slot data 2) ; e841 (##sys#slot data 3))))))))) ; v842843(define select-frame844 (let ((display display))845 (lambda (n)846 (cond ((or (not (number? n))847 (not ##sys#repl-recent-call-chain)848 (fx< n 0)849 (fx>= n (length ##sys#repl-recent-call-chain)))850 (display "no such frame\n"))851 (else852 (set! selected-frame853 (list-ref854 ##sys#repl-recent-call-chain855 (fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))856 (show-frameinfo selected-frame))))))857858(define copy-from-frame859 (let ((display display)860 (newline newline)861 (call/cc call/cc))862 (lambda (name)863 (let* ((ct (or ##sys#repl-recent-call-chain '()))864 (len (length ct))865 (name866 (cond ((symbol? name) (##sys#slot name 1)) ; name867 ((string? name) name)868 (else869 (display "string or symbol required for `,g'\n")870 #f))))871 (define (compare sym)872 (let ((str (##sys#slot sym 1))) ; name873 (string=?874 name875 (substring str 0 (min (string-length name) (string-length str))))))876 (if name877 (call/cc878 (lambda (return)879 (define (fail msg)880 (display msg)881 (newline)882 (return (##sys#void)))883 (do ((ct ct (cdr ct)))884 ((null? ct) (fail "no environment in frame"))885 ;;XXX this should be refactored as it duplicates the code above886 (let* ((info (car ct))887 (here (eq? selected-frame info))888 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)889 (finfo (##sys#structure? data 'frameinfo)))890 (when (and here finfo)891 (for-each892 (lambda (e v)893 (do ((i 0 (fx+ i 1))894 (be e (cdr be)))895 ((null? be))896 (when (compare (car be))897 (display "; getting ")898 (display (car be))899 (newline)900 (history-add (list (##sys#slot v i)))901 (return (##sys#slot v i)))))902 (##sys#slot data 2) ; e903 (##sys#slot data 3)) ; v904 (fail (##sys#string-append "no such variable: " name)))))))905 (##sys#void))))))906907908;;; Handle some signals:909910(define-foreign-variable _sigint int "SIGINT")911912(define-syntax defhandler913 (syntax-rules ()914 ((_ sig handler)915 (begin916 (##core#inline "C_establish_signal_handler" sig sig)917 (##sys#setslot ##sys#signal-vector sig handler)))))918919(defhandler _sigint (lambda (n) (##sys#user-interrupt-hook)))920921922;;; Start interpreting:923924(define (member* keys set)925 (let loop ((set set))926 (and (pair? set)927 (let find ((ks keys))928 (cond ((null? ks) (loop (cdr set)))929 ((equal? (car ks) (car set)) set)930 (else (find (cdr ks))) ) ) ) ) )931932(define-constant short-options933 '(#\k #\s #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P #\K) )934935(define-constant long-options936 '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-no-feature" "-eval"937 "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"938 "-r5rs-syntax" "-setup-mode"939 "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"940 "-include-path" "-release" "-print" "-pretty-print" "--") )941942(define (canonicalize-args args)943 (let loop ((args args))944 (if (null? args)945 '()946 (let ((x (car args)))947 (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)948 ((and (fx= (##sys#size x) 2)949 (char=? #\- (##core#inline "C_subchar" x 0)))950 (if (memq (##core#inline "C_subchar" x 1) short-options)951 (cons x (loop (cdr args)))952 (##sys#error "invalid option" x)))953 ((and (fx> (##sys#size x) 2)954 (char=? #\- (##core#inline "C_subchar" x 0))955 (not (member x long-options)) )956 (if (char=? #\: (##core#inline "C_subchar" x 1))957 (loop (cdr args))958 (let ((cs (string->list (substring x 1))))959 (if (findall cs short-options)960 (append (map (cut string #\- <>) cs) (loop (cdr args)))961 (##sys#error "invalid option" x) ) ) ) )962 (else (cons x (loop (cdr args)))))))))963964(define (findall chars clist)965 (let loop ((chars chars))966 (or (null? chars)967 (and (memq (car chars) clist)968 (loop (cdr chars))))))969970(define-constant simple-options971 '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"972 "-i" "-case-insensitive"973 "-no-parentheses-synonyms" "-no-symbol-escape" "-r5rs-syntax" "-setup-mode"974 ; Not "simple" but processed early975 "-ss" "-sx" "-s" "-script") )976977(define-constant complex-options978 '("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )979980(define (string-trim str)981 (let loop ((front 0)982 (back (string-length str)))983 (cond ((= front back) "")984 ((char-whitespace? (string-ref str front))985 (loop (add1 front) back))986 ((char-whitespace? (string-ref str (sub1 back)))987 (loop front (sub1 back)))988 (else (substring str front back)))))989990(define (string->extension-name str)991 (let ((str (string-trim str)))992 (if (and (positive? (string-length str))993 (char=? #\( (string-ref str 0)))994 (handle-exceptions ex995 (##sys#error "invalid import specification" str)996 (with-input-from-string str read))997 (string->symbol str))))998999(define (run)1000 (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]1001 [args (canonicalize-args (command-line-arguments))]1002 ; Check for these before 'args' is updated by any 'extraopts'1003 [kwstyle (member* '("-K" "-keyword-style") args)]1004 [script (member* '("-ss" "-sx" "-s" "-script") args)])1005 (cond [script1006 (when (or (not (pair? (cdr script)))1007 (zero? (string-length (cadr script)))1008 (char=? #\- (string-ref (cadr script) 0)) )1009 (##sys#error "missing or invalid script argument"))1010 (program-name (cadr script))1011 (command-line-arguments (cddr script))1012 ;; 2012-10-04 (felix) left 'script activated to avoid breaking too much code1013 (register-feature! 'chicken-script)1014 (set-cdr! (cdr script) '())1015 (when ##sys#windows-platform1016 (and-let* ((sname (lookup-script-file (cadr script))))1017 (set-car! (cdr script) sname) ) ) ]1018 [else1019 (set! args (append (canonicalize-args extraopts) args))1020 (and-let* ([p (member "--" args)])1021 (set-cdr! p '()) ) ] )1022 (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]1023 [batch (or script (member* '("-b" "-batch") args) eval?)]1024 [quietflag (member* '("-q" "-quiet") args)]1025 [quiet (or script quietflag eval?)])1026 (define (collect-options opt)1027 (let loop ([opts args])1028 (cond [(member opt opts)1029 => (lambda (p)1030 (if (null? (cdr p))1031 (##sys#error "missing argument to command-line option" opt)1032 (cons (cadr p) (loop (cddr p)))) ) ]1033 [else '()] ) ) )1034 (define (loadinit)1035 (let* ((sys-dir (system-config-directory))1036 (cfg-fn (and sys-dir (make-pathname (list sys-dir "chicken")1037 init-file)))1038 (home (get-environment-variable "HOME"))1039 (home-fn (and home (not (string=? home ""))1040 (make-pathname home (string-append "." init-file)))))1041 (cond ((and cfg-fn (file-exists? cfg-fn))1042 (load cfg-fn))1043 ((and home-fn (file-exists? home-fn))1044 (load home-fn) ) ) ) )1045 (define (evalstring str #!optional (rec (lambda _ (void))))1046 (let ((in (open-input-string str))1047 (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing1048 (do ([x (read-with-source-info in) (read-with-source-info in)])1049 ((eof-object? x))1050 (rec (receive (eval x))) ) ) )1051 (when (member* '("-h" "-help" "--help") args)1052 (print-usage)1053 (exit 0) )1054 (when (member "-version" args)1055 (print-banner)1056 (exit 0) )1057 (when (member "-setup-mode" args)1058 (set! ##sys#setup-mode #t))1059 (when (member "-release" args)1060 (print (chicken-version))1061 (exit 0) )1062 (when (member* '("-w" "-no-warnings") args)1063 (unless quiet (display "Warnings are disabled\n"))1064 (set! ##sys#warnings-enabled #f) )1065 (when (member* '("-i" "-case-insensitive") args)1066 (unless quiet (display "Identifiers and symbols are case insensitive\n"))1067 (register-feature! 'case-insensitive)1068 (case-sensitive #f) )1069 (for-each register-feature! (collect-options "-feature"))1070 (for-each register-feature! (collect-options "-D"))1071 (for-each unregister-feature! (collect-options "-no-feature"))1072 (set! ##sys#include-pathnames1073 (delete-duplicates1074 (append (map chop-separator (collect-options "-include-path"))1075 (map chop-separator (collect-options "-I"))1076 ##sys#include-pathnames)1077 string=?) )1078 (when kwstyle1079 (cond [(not (pair? (cdr kwstyle)))1080 (##sys#error "missing argument to `-keyword-style' option") ]1081 [(string=? "prefix" (cadr kwstyle))1082 (keyword-style #:prefix) ]1083 [(string=? "none" (cadr kwstyle))1084 (keyword-style #:none) ]1085 [(string=? "suffix" (cadr kwstyle))1086 (keyword-style #:suffix) ] ) )1087 (when (member* '("-no-parentheses-synonyms") args)1088 (unless quiet (display "Disabled support for parentheses synonyms\n"))1089 (parentheses-synonyms #f) )1090 (when (member* '("-no-symbol-escape") args)1091 (unless quiet (display "Disabled support for escaped symbols\n"))1092 (symbol-escape #f) )1093 (when (member* '("-r5rs-syntax") args)1094 (unless quiet (display "Disabled the CHICKEN extensions to R5RS syntax\n"))1095 (case-sensitive #f)1096 (keyword-style #:none)1097 (parentheses-synonyms #f)1098 (symbol-escape #f) )1099 ;; Load the default modules into the evaluation environment.1100 ;; This is done before setting load-verbose => #t to avoid1101 ;; spurious import messages.1102 (eval `(import-for-syntax ,@default-syntax-imports))1103 (eval `(import ,@default-imports))1104 (unless quiet1105 (load-verbose #t)1106 (print-banner)1107 (print "Type ,? for help."))1108 (unless (or (member* '("-n" "-no-init") args) script eval?)1109 (loadinit))1110 (when batch1111 (set! ##sys#notices-enabled #f))1112 (do ([args args (cdr args)])1113 ((null? args)1114 (register-repl-history!)1115 (unless batch1116 (repl default-evaluator)1117 (##sys#write-char-0 #\newline ##sys#standard-output) ) )1118 (let* ((arg (car args)))1119 (cond ((member arg simple-options))1120 ((member arg complex-options)1121 (set! args (cdr args)) )1122 ((or (string=? "-R" arg) (string=? "-require-extension" arg))1123 (eval `(import ,(string->extension-name (cadr args))))1124 (set! args (cdr args)) )1125 ((or (string=? "-e" arg) (string=? "-eval" arg))1126 (evalstring (cadr args))1127 (set! args (cdr args)) )1128 ((or (string=? "-p" arg) (string=? "-print" arg))1129 (evalstring (cadr args) (cut for-each print <...>))1130 (set! args (cdr args)) )1131 ((or (string=? "-P" arg) (string=? "-pretty-print" arg))1132 (evalstring (cadr args) (cut for-each pretty-print <...>) )1133 (set! args (cdr args)) )1134 (else1135 (let ((scr (and script (car script))))1136 (load1137 arg1138 (and (equal? "-sx" scr)1139 (lambda (x)1140 (let* ((str (with-output-to-string (cut pretty-print x)))1141 (len (string-length str)))1142 (flush-output ##sys#standard-output)1143 (display "\n; " ##sys#standard-error)1144 (do ((i 0 (fx+ i 1)))1145 ((fx>= i len))1146 (let ((c (string-ref str i)))1147 (write-char c ##sys#standard-error)1148 (when (char=? #\newline c)1149 (display "; " ##sys#standard-error))))1150 (newline ##sys#standard-error)1151 (eval x)))))1152 (when (equal? "-ss" scr)1153 (receive rs ((eval 'main) (command-line-arguments))1154 (let ((r (optional rs)))1155 (exit (if (fixnum? r) r 0)))))))))))))11561157(run))