~ 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'")436437438;;; Parse options from string:439440(define (parse-option-string str)441 (let ([ins (open-input-string str)])442 (map (lambda (o)443 (if (string? o)444 o445 (let ([os (open-output-string)])446 (write o os)447 (get-output-string os) ) ) )448 (handle-exceptions ex (##sys#error "invalid option syntax" str)449 (do ([x (read ins) (read ins)]450 [xs '() (cons x xs)] )451 ((eof-object? x) (reverse xs)) ) ) ) ) )452453454;;; Print status information:455456(define report457 (let ((printf printf)458 (sort sort)459 (with-output-to-port with-output-to-port)460 (current-output-port current-output-port)461 (argv argv)462 (prefix (foreign-value "C_INSTALL_PREFIX" c-string)))463 (lambda port464 (with-output-to-port (if (pair? port) (car port) (current-output-port))465 (lambda ()466 (gc)467 (let ((sinfo (##sys#symbol-table-info))468 (minfo (memory-statistics))469 (interrupts (foreign-value "C_interrupts_enabled" bool))470 (fixed-heap (foreign-value "C_heap_size_is_fixed" bool))471 (downward-stack (foreign-value "C_STACK_GROWS_DOWNWARD" bool)))472 (define (shorten n) (/ (truncate (* n 100)) 100))473 (printf "Features:~%~%")474 (let ((fs (sort (map keyword->string ##sys#features) string<?))475 (c 0))476 (for-each477 (lambda (f)478 (printf " ~a" f)479 (let* ((len (string-length f))480 (pad (- 16 len)))481 (set! c (add1 c))482 (when (<= pad 0)483 (set! c (add1 c))484 (set! pad (+ pad 18)))485 (cond ((>= c 3)486 (display "\n")487 (set! c 0))488 (else489 (display (make-string pad #\space))))))490 fs))491 (printf "~%~%~492 Machine type: \t~A (~A-bit)~%~493 Software type: \t~A~%~494 Software version:\t~A~%~495 Build platform: \t~A~%~496 Installation prefix:\t~A~%~497 Extension installation location:\t~A~%~498 Extension path: \t~A~%~499 Include path: \t~A~%~500 Keyword style: \t~A~%~501 Symbol-table load:\t~S~% ~502 Avg bucket length:\t~S~% ~503 Total symbol count:\t~S~%~504 Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~505 nursery size is ~S bytes, stack grows ~A~%~506 Command line: \t~S~%"507 (machine-type)508 (foreign-value "C_WORD_SIZE" int)509 (software-type)510 (software-version)511 (build-platform)512 prefix513 (installation-repository)514 (repository-path)515 ##sys#include-pathnames516 (keyword->string (keyword-style))517 (shorten (vector-ref sinfo 0))518 (shorten (vector-ref sinfo 1))519 (vector-ref sinfo 2)520 (vector-ref minfo 0)521 (if fixed-heap " (fixed)" "")522 (vector-ref minfo 1)523 (vector-ref minfo 2)524 (if downward-stack "downward" "upward")525 (argv))526 (##sys#write-char-0 #\newline ##sys#standard-output)527 (when interrupts (display "interrupts are enabled\n"))528 (##core#undefined) ) ) ) ) ) )529530531;;; Describe & dump:532533(define bytevector-data534 '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)535 (s8vector "vector of signed bytes" s8vector-length s8vector-ref)536 (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)537 (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)538 (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)539 (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)540 (u64vector "vector of unsigned 64-bit words" u64vector-length u64vector-ref)541 (s64vector "vector of signed 64-bit words" s64vector-length s64vector-ref)542 (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)543 (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )544545(define (circular-list? x)546 (let lp ((x x) (lag x))547 (and (pair? x)548 (let ((x (cdr x)))549 (and (pair? x)550 (let ((x (cdr x))551 (lag (cdr lag)))552 (or (eq? x lag) (lp x lag))))))))553554(define (improper-pairs? x)555 (let lp ((x x))556 (if (not (pair? x)) #f557 (or (eq? x (car x))558 (lp (cdr x))))))559560(define-constant max-describe-lines 40)561562(define describe563 (let ([sprintf sprintf]564 [printf printf]565 [fprintf fprintf]566 [length length]567 [list-ref list-ref]568 [string-ref string-ref])569 (lambda (x #!optional (out ##sys#standard-output))570 (define (descseq name plen pref start)571 (let ((len (fx- (plen x) start)))572 (when name (fprintf out "~A of length ~S~%" name len))573 (let loop1 ((i 0))574 (cond ((fx>= i len))575 ((fx>= i max-describe-lines)576 (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )577 (else578 (let ((v (pref x (fx+ start i))))579 (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))580 (cond ((fx>= j len)581 (##sys#with-print-length-limit582 1000583 (lambda ()584 (fprintf out " ~S: ~S" i v)))585 (if (fx> n 1)586 (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"587 (fx- n 1)588 (if (eq? n 2) "" "s"))589 (newline out) )590 (loop1 (fx+ i n)) )591 ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))592 (else (loop2 n len)) ) ) ) ) ) ) ) )593 (when (##sys#permanent? x)594 (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )595 (cond ((char? x)596 (let ([code (char->integer x)])597 (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) )598 ((eq? x #t) (fprintf out "boolean true~%"))599 ((eq? x #f) (fprintf out "boolean false~%"))600 ((null? x) (fprintf out "empty list~%"))601 ((bwp-object? x)602 (fprintf out "broken weak pointer~%"))603 ((eof-object? x) (fprintf out "end-of-file object~%"))604 ((eq? (##sys#void) x) (fprintf out "unspecified object~%"))605 ((fixnum? x)606 (fprintf out "exact immediate integer ~S~% #x~X~% #o~O~% #b~B"607 x x x x)608 (let ([code (integer->char x)])609 (when (fx< x #x10000) (fprintf out ", character ~S" code)) )610 (##sys#write-char-0 #\newline ##sys#standard-output) )611 ((bignum? x)612 (fprintf out "exact large integer ~S~% #x~X~% #o~O~% #b~B~%"613 x x x x) )614 ((##core#inline "C_unboundvaluep" x)615 (fprintf out "unbound value~%"))616 ((flonum? x) (fprintf out "inexact rational number ~S~%" x))617 ((ratnum? x) (fprintf out "exact ratio ~S~%" x))618 ((cplxnum? x) (fprintf out "~A complex number ~S~%"619 (if (exact? x) "exact" "inexact") x))620 ((number? x) (fprintf out "number ~S~%" x))621 ((string? x) (descseq "string" string-length string-ref 0))622 ((vector? x) (descseq "vector" ##sys#size ##sys#slot 0))623 ((keyword? x)624 (fprintf out "keyword symbol with name ~s~%"625 (##sys#symbol->string/shared x)))626 ((symbol? x)627 (unless (##sys#symbol-has-toplevel-binding? x)628 (display "unbound " out))629 (fprintf out "~asymbol with name ~S~%"630 (if (##sys#interned-symbol? x) "" "uninterned ")631 (##sys#symbol->string/shared x))632 (let ((plist (##sys#slot x 2)))633 (unless (null? plist)634 (display " \nproperties:\n\n" out)635 (do ((plist plist (cddr plist)))636 ((null? plist))637 (fprintf out " ~s\t" (car plist))638 (##sys#with-print-length-limit639 1000640 (lambda ()641 (write (cadr plist) out) ) )642 (newline out) ) ) ) )643 ((or (circular-list? x) (improper-pairs? x))644 (fprintf out "circular structure: ")645 (let loop-print ((x x)646 (cdr-refs (list x)))647 (cond ((or (atom? x)648 (null? x)) (printf "eol~%"))649 ((memq (car x) cdr-refs)650 (fprintf out "(circle)~%" ))651 ((not (memq (car x) cdr-refs))652 (fprintf out "~S -> " (car x))653 (loop-print (cdr x) (cons (car x) cdr-refs) )))))654 ((list? x) (descseq "list" length list-ref 0))655 ((pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x)))656 ((procedure? x)657 (let ([len (##sys#size x)])658 (descseq659 (sprintf "procedure with code pointer 0x~X" (##sys#peek-unsigned-integer x 0))660 ##sys#size ##sys#slot 1) ) )661 ((port? x)662 (fprintf out663 "~A port of type ~A with name ~S and ~A encoding~%"664 (if (##sys#slot x 1) "input" "output")665 (##sys#slot x 7)666 (##sys#slot x 3)667 (##sys#slot x 15) ) )668 ((not (##core#inline "C_blockp" x))669 ;; catch immediates here, as ##sys#locative? crashes on non-block670 (fprintf out "unknown immediate object~%"))671 ((##sys#locative? x)672 (fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"673 (##sys#peek-unsigned-integer x 0)674 (##sys#slot x 1)675 (case (##sys#slot x 2)676 ((0) "slot")677 ((1) "char")678 ((2) "u8vector")679 ((3) "s8vector")680 ((4) "u16vector")681 ((5) "s16vector")682 ((6) "u32vector")683 ((7) "s32vector")684 ((8) "u64vector")685 ((9) "s64vector")686 ((10) "f32vector")687 ((11) "f64vector") ) ) )688 ((##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0)))689 ((##sys#bytevector? x)690 (let ([len (##sys#size x)])691 (fprintf out "bytevector of size ~S:~%" len)692 (hexdump x len ##sys#byte out) ) )693 ((##core#inline "C_lambdainfop" x)694 (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) )695 ((##sys#structure? x 'hash-table)696 (let ((n (##sys#slot x 2)))697 (fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"698 n (if (fx= n 1) "" "s") (##sys#slot x 3)) )699 (fprintf out " hash function: ~a~%" (##sys#slot x 4))700 ;; this copies code out of srfi-69.scm, but we don't want to depend on it701 (let* ((vec (##sys#slot x 1))702 (len (##sys#size vec)) )703 (do ((i 0 (fx+ i 1)) )704 ((fx>= i len))705 (for-each706 (lambda (bucket)707 (fprintf out " ~S\t-> ~S~%"708 (##sys#slot bucket 0) (##sys#slot bucket 1)) )709 (##sys#slot vec i)) ) ) )710 ((##sys#structure? x 'condition)711 (fprintf out "condition: ~s~%" (##sys#slot x 1))712 (for-each713 (lambda (k)714 (fprintf out " ~s~%" k)715 (let loop ((props (##sys#slot x 2)))716 (unless (null? props)717 (when (eq? k (caar props))718 (##sys#with-print-length-limit719 100720 (lambda ()721 (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))722 (newline out))723 (loop (cddr props)) ) ) )724 (##sys#slot x 1) ) )725 ((##sys#generic-structure? x)726 (let ((st (##sys#slot x 0)))727 (cond ((assq st bytevector-data) =>728 (lambda (data)729 (apply descseq (append (map eval (cdr data)) (list 0)))) )730 (else731 (fprintf out "structure of type `~S':~%" (##sys#slot x 0))732 (descseq #f ##sys#size ##sys#slot 1) ) ) ) )733 (else (fprintf out "unknown object~%")) )734 (##sys#void) ) ) )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)748 (let ((bv (##sys#slot x 0)))749 (hexdump bv (bestlen (fx- (##sys#size bv) 1)) ##sys#byte out))]750 [(and (not (##sys#immediate? x)) (##sys#pointer? x))751 (hexdump x 32 ##sys#peek-byte out) ]752 [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))753 (let ([bv (##sys#slot x 1)])754 (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]755 [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )756757(define hexdump758 (let ([display display]759 [string-append string-append]760 [make-string make-string]761 [write-char write-char] )762 (lambda (bv len ref out)763764 (define (justify n m base lead)765 (let* ([s (number->string n base)]766 [len (string-length s)] )767 (if (fx< len m)768 (string-append (make-string (fx- m len) lead) s)769 s) ) )770771 (do ([a 0 (fx+ a 16)])772 ((fx>= a len))773 (display (justify a 4 10 #\space) out)774 (write-char #\: out)775 (do ([j 0 (fx+ j 1)]776 [a a (fx+ a 1)] )777 ((or (fx>= j 16) (fx>= a len))778 (when (fx>= a len)779 (let ((o (fxmod len 16)))780 (unless (fx= o 0)781 (do ((k (fx- 16 o) (fx- k 1)))782 ((fx= k 0))783 (display " " out) ) ) ) ) )784 (write-char #\space out)785 (display (justify (ref bv a) 2 16 #\0) out) )786 (write-char #\space out)787 (do ([j 0 (fx+ j 1)]788 [a a (fx+ a 1)] )789 ((or (fx>= j 16) (fx>= a len)))790 (let ([c (ref bv a)])791 (if (and (fx>= c 32) (fx< c 128))792 (write-char (integer->char c) out)793 (write-char #\. out) ) ) )794 (write-char #\newline out) ) ) ) )795796797;;; Frame-info operations:798799(define show-frameinfo800 (let ((newline newline)801 (display display))802 (lambda (fn)803 (define (prin1 x)804 (##sys#with-print-length-limit805 100806 (lambda ()807 (##sys#print x #t ##sys#standard-output))))808 (let* ((ct (or ##sys#repl-recent-call-chain '()))809 (len (length ct)))810 (set! selected-frame811 (or (and (memq fn ct) fn)812 (and (fx> len 0)813 (list-ref ct (fx- len 1)))))814 (do ((ct ct (cdr ct))815 (i (fx- len 1) (fx- i 1)))816 ((null? ct))817 (let* ((info (car ct))818 (here (eq? selected-frame info))819 (form (##sys#slot info 1)) ; cooked1 (expr/form)820 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)821 (finfo (##sys#structure? data 'frameinfo))822 (cntr (if finfo (##sys#slot data 1) data))) ; cntr823 (printf "~a~a:~a\t~a\t "824 (if here #\* #\space)825 i826 (if (and finfo (pair? (##sys#slot data 2))) "[]" " ") ; e827 (##sys#slot info 0)) ; raw828 (when cntr (printf "[~a] " cntr))829 (when form (prin1 form))830 (newline)831 (when (and here finfo)832 (for-each833 (lambda (e v)834 (unless (null? e)835 (display " ---\n")836 (do ((i 0 (fx+ i 1))837 (be e (cdr be)))838 ((null? be))839 (printf " ~s:\t " (car be))840 (prin1 (##sys#slot v i))841 (newline))))842 (##sys#slot data 2) ; e843 (##sys#slot data 3))))))))) ; v844845(define select-frame846 (let ((display display))847 (lambda (n)848 (cond ((or (not (number? n))849 (not ##sys#repl-recent-call-chain)850 (fx< n 0)851 (fx>= n (length ##sys#repl-recent-call-chain)))852 (display "no such frame\n"))853 (else854 (set! selected-frame855 (list-ref856 ##sys#repl-recent-call-chain857 (fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))858 (show-frameinfo selected-frame))))))859860(define copy-from-frame861 (let ((display display)862 (newline newline)863 (call/cc call-with-current-continuation))864 (lambda (name)865 (let* ((ct (or ##sys#repl-recent-call-chain '()))866 (len (length ct))867 (name868 (cond ((symbol? name) (##sys#slot name 1)) ; name869 ((string? name) name)870 (else871 (display "string or symbol required for `,g'\n")872 #f))))873 (define (compare sym)874 (let ((str (##sys#slot sym 1))) ; name875 (string=?876 name877 (substring str 0 (min (string-length name) (string-length str))))))878 (if name879 (call/cc880 (lambda (return)881 (define (fail msg)882 (display msg)883 (newline)884 (return (##sys#void)))885 (do ((ct ct (cdr ct)))886 ((null? ct) (fail "no environment in frame"))887 ;;XXX this should be refactored as it duplicates the code above888 (let* ((info (car ct))889 (here (eq? selected-frame info))890 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)891 (finfo (##sys#structure? data 'frameinfo)))892 (when (and here finfo)893 (for-each894 (lambda (e v)895 (do ((i 0 (fx+ i 1))896 (be e (cdr be)))897 ((null? be))898 (when (compare (car be))899 (display "; getting ")900 (display (car be))901 (newline)902 (history-add (list (##sys#slot v i)))903 (return (##sys#slot v i)))))904 (##sys#slot data 2) ; e905 (##sys#slot data 3)) ; v906 (fail (##sys#string-append "no such variable: " name)))))))907 (##sys#void))))))908909910;;; Handle some signals:911912(define-foreign-variable _sigint int "SIGINT")913914(define-syntax defhandler915 (syntax-rules ()916 ((_ sig handler)917 (begin918 (##core#inline "C_establish_signal_handler" sig sig)919 (##sys#setslot ##sys#signal-vector sig handler)))))920921(defhandler _sigint (lambda (n) (##sys#user-interrupt-hook)))922923924;;; Start interpreting:925926(define (member* keys set)927 (let loop ((set set))928 (and (pair? set)929 (let find ((ks keys))930 (cond ((null? ks) (loop (cdr set)))931 ((equal? (car ks) (car set)) set)932 (else (find (cdr ks))) ) ) ) ) )933934(define-constant short-options935 '(#\k #\s #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P #\K) )936937(define-constant long-options938 '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-no-feature" "-eval"939 "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"940 "-r7rs-syntax" "-setup-mode"941 "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"942 "-include-path" "-release" "-print" "-pretty-print" "--") )943944(define (canonicalize-args args)945 (let loop ((args args))946 (if (null? args)947 '()948 (let ((x (car args)))949 (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)950 ((and (fx= (string-length x) 2)951 (char=? #\- (string-ref x 0)))952 (if (memq (string-ref x 1) short-options)953 (cons x (loop (cdr args)))954 (##sys#error "invalid option" x)))955 ((and (fx> (string-length x) 2)956 (char=? #\- (string-ref x 0))957 (not (member x long-options)) )958 (if (char=? #\: (string-ref x 1))959 (loop (cdr args))960 (let ((cs (string->list (substring x 1))))961 (if (findall cs short-options)962 (append (map (cut string #\- <>) cs) (loop (cdr args)))963 (##sys#error "invalid option" x) ) ) ) )964 (else (cons x (loop (cdr args)))))))))965966(define (findall chars clist)967 (let loop ((chars chars))968 (or (null? chars)969 (and (memq (car chars) clist)970 (loop (cdr chars))))))971972(define-constant simple-options973 '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"974 "-i" "-case-insensitive"975 "-no-parentheses-synonyms" "-r7rs-syntax" "-setup-mode"976 ; Not "simple" but processed early977 "-ss" "-sx" "-s" "-script") )978979(define-constant complex-options980 '("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )981982(define (string-trim str)983 (let loop ((front 0)984 (back (string-length str)))985 (cond ((= front back) "")986 ((char-whitespace? (string-ref str front))987 (loop (add1 front) back))988 ((char-whitespace? (string-ref str (sub1 back)))989 (loop front (sub1 back)))990 (else (substring str front back)))))991992(define (string->extension-name str)993 (let ((str (string-trim str)))994 (if (and (positive? (string-length str))995 (char=? #\( (string-ref str 0)))996 (handle-exceptions ex997 (##sys#error "invalid import specification" str)998 (with-input-from-string str read))999 (string->symbol str))))10001001(define (run)1002 (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]1003 [args (canonicalize-args (command-line-arguments))]1004 ; Check for these before 'args' is updated by any 'extraopts'1005 [kwstyle (member* '("-K" "-keyword-style") args)]1006 [script (member* '("-ss" "-sx" "-s" "-script") args)])1007 (cond [script1008 (when (or (not (pair? (cdr script)))1009 (zero? (string-length (cadr script)))1010 (char=? #\- (string-ref (cadr script) 0)) )1011 (##sys#error "missing or invalid script argument"))1012 (program-name (cadr script))1013 (command-line-arguments (cddr script))1014 ;; 2012-10-04 (felix) left 'script activated to avoid breaking too much code1015 (register-feature! 'chicken-script)1016 (set-cdr! (cdr script) '())1017 (when ##sys#windows-platform1018 (and-let* ((sname (lookup-script-file (cadr script))))1019 (set-car! (cdr script) sname) ) ) ]1020 [else1021 (set! args (append (canonicalize-args extraopts) args))1022 (and-let* ([p (member "--" args)])1023 (set-cdr! p '()) ) ] )1024 (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]1025 [batch (or script (member* '("-b" "-batch") args) eval?)]1026 [quietflag (member* '("-q" "-quiet") args)]1027 [quiet (or script quietflag eval?)])1028 (define (collect-options opt)1029 (let loop ([opts args])1030 (cond [(member opt opts)1031 => (lambda (p)1032 (if (null? (cdr p))1033 (##sys#error "missing argument to command-line option" opt)1034 (cons (cadr p) (loop (cddr p)))) ) ]1035 [else '()] ) ) )1036 (define (loadinit)1037 (let* ((sys-dir (system-config-directory))1038 (cfg-fn (and sys-dir (make-pathname (list sys-dir "chicken")1039 init-file)))1040 (home (get-environment-variable "HOME"))1041 (home-fn (and home (not (string=? home ""))1042 (make-pathname home (string-append "." init-file)))))1043 (cond ((and cfg-fn (file-exists? cfg-fn))1044 (load cfg-fn))1045 ((and home-fn (file-exists? home-fn))1046 (load home-fn) ) ) ) )1047 (define (evalstring str #!optional (rec (lambda _ (void))))1048 (let ((in (open-input-string str))1049 (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing1050 (do ([x (read-with-source-info in) (read-with-source-info in)])1051 ((eof-object? x))1052 (rec (receive (eval x))) ) ) )1053 (when (member* '("-h" "-help" "--help") args)1054 (print-usage)1055 (exit 0) )1056 (when (member "-version" args)1057 (print-banner)1058 (exit 0) )1059 (when (member "-setup-mode" args)1060 (set! ##sys#setup-mode #t))1061 (when (member "-release" args)1062 (print (chicken-version))1063 (exit 0) )1064 (when (member* '("-w" "-no-warnings") args)1065 (unless quiet (display "Warnings are disabled\n"))1066 (set! ##sys#warnings-enabled #f) )1067 (when (member* '("-i" "-case-insensitive") args)1068 (unless quiet (display "Identifiers and symbols are case insensitive\n"))1069 (register-feature! 'case-insensitive)1070 (case-sensitive #f) )1071 (for-each register-feature! (collect-options "-feature"))1072 (for-each register-feature! (collect-options "-D"))1073 (for-each unregister-feature! (collect-options "-no-feature"))1074 (set! ##sys#include-pathnames1075 (delete-duplicates1076 (append (map chop-separator (collect-options "-include-path"))1077 (map chop-separator (collect-options "-I"))1078 ##sys#include-pathnames)1079 string=?) )1080 (when kwstyle1081 (cond [(not (pair? (cdr kwstyle)))1082 (##sys#error "missing argument to `-keyword-style' option") ]1083 [(string=? "prefix" (cadr kwstyle))1084 (keyword-style #:prefix) ]1085 [(string=? "none" (cadr kwstyle))1086 (keyword-style #:none) ]1087 [(string=? "suffix" (cadr kwstyle))1088 (keyword-style #:suffix) ] ) )1089 (when (member* '("-no-parentheses-synonyms") args)1090 (unless quiet (display "Disabled support for parentheses synonyms\n"))1091 (parentheses-synonyms #f) )1092 (when (member* '("-r7rs-syntax") args)1093 (unless quiet (display "Disabled the CHICKEN extensions to R7RS syntax\n"))1094 (case-sensitive #f)1095 (keyword-style #:none)1096 (parentheses-synonyms #f) )1097 ;; Load the the default modules into the evaluation environment.1098 ;; This is done before setting load-verbose => #t to avoid1099 ;; spurious import messages.1100 (eval `(import-for-syntax ,@default-syntax-imports))1101 (eval `(import ,@default-imports))1102 (unless quiet1103 (load-verbose #t)1104 (print-banner)1105 (print "Type ,? for help."))1106 (unless (or (member* '("-n" "-no-init") args) script eval?)1107 (loadinit))1108 (when batch1109 (set! ##sys#notices-enabled #f))1110 (do ([args args (cdr args)])1111 ((null? args)1112 (register-repl-history!)1113 (unless batch1114 (repl default-evaluator)1115 (##sys#write-char-0 #\newline ##sys#standard-output) ) )1116 (let* ((arg (car args)))1117 (cond ((member arg simple-options))1118 ((member arg complex-options)1119 (set! args (cdr args)) )1120 ((or (string=? "-R" arg) (string=? "-require-extension" arg))1121 (eval `(import ,(string->extension-name (cadr args))))1122 (set! args (cdr args)) )1123 ((or (string=? "-e" arg) (string=? "-eval" arg))1124 (evalstring (cadr args))1125 (set! args (cdr args)) )1126 ((or (string=? "-p" arg) (string=? "-print" arg))1127 (evalstring (cadr args) (cut for-each print <...>))1128 (set! args (cdr args)) )1129 ((or (string=? "-P" arg) (string=? "-pretty-print" arg))1130 (evalstring (cadr args) (cut for-each pretty-print <...>) )1131 (set! args (cdr args)) )1132 (else1133 (let ((scr (and script (car script))))1134 (load1135 arg1136 (and (equal? "-sx" scr)1137 (lambda (x)1138 (let* ((str (with-output-to-string (cut pretty-print x)))1139 (len (string-length str)))1140 (flush-output ##sys#standard-output)1141 (display "\n; " ##sys#standard-error)1142 (do ((i 0 (fx+ i 1)))1143 ((fx>= i len))1144 (let ((c (string-ref str i)))1145 (write-char c ##sys#standard-error)1146 (when (char=? #\newline c)1147 (display "; " ##sys#standard-error))))1148 (newline ##sys#standard-error)1149 (eval x)))))1150 (when (equal? "-ss" scr)1151 (receive rs ((eval 'main) (command-line-arguments))1152 (let ((r (optional rs)))1153 (exit (if (fixnum? r) r 0)))))))))))))11541155(run))