~ 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 (##sys#with-print-length-limit ##sys#repl-print-length-limit88 (lambda () (write/labels o p)))89 (newline)))9091(define editor-command (make-parameter #f))92(define selected-frame #f)9394(define default-editor95 (or (get-environment-variable "EDITOR")96 (get-environment-variable "VISUAL")97 (if (get-environment-variable "EMACS")98 "emacsclient"99 "vi"))) ; shudder100101102;;; Print all sorts of information:103104(define (print-usage)105 (display #<<EOF106usage: csi [OPTION ...] [FILENAME ...]107108 `csi' is the CHICKEN interpreter.109110 FILENAME is a Scheme source file name with optional extension. OPTION may be111 one of the following:112113 -h -help display this text and exit114 -version display version and exit115 -release print release number and exit116 -i -case-insensitive enable case-insensitive reading117 -e -eval EXPRESSION evaluate given expression118 -p -print EXPRESSION evaluate and print result(s)119 -P -pretty-print EXPRESSION evaluate and print result(s) prettily120 -D -feature SYMBOL register feature identifier121 -no-feature SYMBOL disable built-in feature identifier122 -q -quiet do not print banner123124EOF125)126 (display #<#EOF127 -n -no-init do not load initialization file #{#\`} #{init-file} #{#\'}128129EOF130)131 (display #<<EOF132 -b -batch terminate after command-line processing133 -w -no-warnings disable all warnings134 -K -keyword-style STYLE enable alternative keyword-syntax135 (prefix, suffix or none)136 -no-parentheses-synonyms disables list delimiter synonyms137 -r7rs-syntax disables the CHICKEN extensions to138 R7RS syntax139 -s -script PATHNAME use csi as interpreter for Scheme scripts140 -ss PATHNAME same as `-s', but invoke `main' procedure141 -sx PATHNAME same as `-s', but print each expression142 as it is evaluated143 -setup-mode prefer the current directory when locating extensions144 -R -require-extension NAME require extension and import before145 executing code146 -I -include-path PATHNAME add PATHNAME to include path147 -- ignore all following options148149EOF150) ) ;| <--- for emacs font-lock151152(define (print-banner) ; duplicate of one in support.scm153 (let ((v (string-split (chicken-version #t) "\n")))154 (print (string-translate* +banner+155 `(("XXX" ,@(cadr v))156 ("YYY" ,@(string-translate* (substring (car v) 9) '(("." . " . ")))))))))157158159;;; Chop terminating separator from pathname:160161(define (dirseparator? c)162 (or (and ##sys#windows-platform (char=? c #\\))163 (char=? c #\/)))164165(define chop-separator166 (let ([substring substring] )167 (lambda (str)168 (let* ((len (sub1 (string-length str)))169 (c (string-ref str len)))170 (if (and (fx> len 0) (dirseparator? c))171 (substring str 0 len)172 str) ) ) ) )173174175;;; Find script in PATH (only used for Windows/DOS):176177(define lookup-script-file178 (let* ([buf (make-string 256)]179 [_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )180 (define (addext name)181 (if (file-exists? name)182 name183 (let ([n2 (string-append name ".bat")])184 (and (file-exists? n2) n2) ) ) )185 (define (string-index proc str1)186 (let ((len (string-length str1)))187 (let loop ((i 0))188 (cond ((fx>= i len) #f)189 ((proc (string-ref str1 i)) i)190 (else (loop (fx+ i 1))) ) ) ) )191 (lambda (name)192 (let ([path (get-environment-variable "PATH")])193 (and (> (string-length name) 0)194 (cond [(dirseparator? (string-ref name 0)) (addext name)]195 [(string-index dirseparator? name)196 (let ((p (_getcwd buf 256)))197 (addext (string-append (chop-separator p) "/" name)) ) ]198 [(addext name)]199 [else200 (let ([name2 (string-append "/" name)])201 (let loop ((ps (##sys#split-path path)))202 (and (pair? ps)203 (let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])204 (or (addext name2)205 (loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )206207208209;;; REPL history references:210211(define history-list (make-vector 32))212(define history-count 1)213214(define history-add215 (let ([vector-resize vector-resize])216 (lambda (vals)217 (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]218 [size (##sys#size history-list)] )219 (when (fx>= history-count size)220 (set! history-list (vector-resize history-list (fx* 2 size))) )221 (vector-set! history-list history-count x)222 (set! history-count (fx+ history-count 1))223 x) ) ) )224225(define (history-clear)226 (vector-fill! history-list (##sys#void)))227228(define history-show229 (let ((newline newline))230 (lambda ()231 (do ((i 1 (fx+ i 1)))232 ((>= i history-count))233 (printf "#~a: " i)234 (##sys#with-print-length-limit235 80236 (lambda ()237 (##sys#print (vector-ref history-list i) #t ##sys#standard-output)))238 (newline)))))239240(define (history-ref index)241 (let ([i (inexact->exact index)])242 (if (and (fx> i 0) (fx<= i history-count))243 (vector-ref history-list i)244 (##sys#error "history entry index out of range" index) ) ) )245246;;; Reader hooks for REPL history:247248(define (register-repl-history!)249 (set! ##sys#user-read-hook250 (let ((old-hook ##sys#user-read-hook))251 (lambda (char port)252 (cond ((or (char=? #\) char) (char-whitespace? char))253 `',(history-ref (fx- history-count 1)))254 (else (old-hook char port))))))255 (set! ##sys#sharp-number-hook256 (lambda (port n) `',(history-ref n))))257258(repl-prompt259 (let ((sprintf sprintf))260 (lambda ()261 (sprintf "#;~A~A> "262 (let ((m (##sys#current-module)))263 (if m264 (sprintf "~a:" (##sys#module-name m))265 ""))266 history-count))))267268269;;; Other REPL customizations:270271(define (tty-input?)272 (or (##core#inline "C_i_tty_forcedp")273 (##sys#tty-port? ##sys#standard-input)))274275(set! ##sys#read-prompt-hook276 (let ([old ##sys#read-prompt-hook])277 (lambda ()278 (when (tty-input?) (old)) ) ) )279280(define command-table '())281282(define (toplevel-command name proc #!optional help)283 (##sys#check-symbol name 'toplevel-command)284 (when help (##sys#check-string help 'toplevel-command))285 (cond ((assq name command-table) =>286 (lambda (a)287 (set-cdr! a (list proc help)) ))288 (else289 (set! command-table (cons (list name proc help) command-table))))290 (##sys#void))291292(define default-evaluator293 (let ((eval eval)294 (load-noisily load-noisily)295 (read (lambda () (chicken.syntax#read-with-source-info (current-input-port)))) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing296 (read-line read-line)297 (display display)298 (string-split string-split)299 (printf printf)300 (expand expand)301 (pretty-print pretty-print)302 (values values) )303 (lambda (form)304 (cond ((eof-object? form) (quit))305 ((and (pair? form)306 (eq? 'unquote (##sys#slot form 0)) )307 (let ((cmd (cadr form)))308 (cond ((assq cmd command-table) =>309 (lambda (p)310 ((cadr p))311 (##sys#void) ) )312 (else313 ;;XXX use `toplevel-command' to define as many as possible of these314 (case cmd315 ((x)316 (let ([x (read)])317 (pretty-print (strip-syntax (expand x)))318 (##sys#void) ) )319 ((p)320 (let* ([x (read)]321 [xe (eval x)] )322 (pretty-print xe)323 (##sys#void) ) )324 ((d)325 (let* ([x (read)]326 [xe (eval x)] )327 (describe xe) ) )328 ((du)329 (let* ([x (read)]330 [xe (eval x)] )331 (dump xe) ) )332 ((dur)333 (let* ([x (read)]334 [n (read)]335 [xe (eval x)]336 [xn (eval n)] )337 (dump xe xn) ) )338 ((r) (report))339 ((q) (quit))340 ((l)341 (let ((fns (string-split (read-line))))342 (for-each load fns)343 (##sys#void) ) )344 ((ln)345 (let ((fns (string-split (read-line))))346 (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)347 (##sys#void) ) )348 ((t)349 (let ((x (read)))350 (receive rs (time (eval x))351 (history-add rs)352 (apply values rs) ) ) )353 ((exn)354 (when ##sys#last-exception355 (history-add (list ##sys#last-exception))356 (describe ##sys#last-exception) ) )357 ((e)358 (let ((r (system359 (string-append360 (or (editor-command) default-editor)361 " " (read-line)))))362 (if (not (zero? r))363 (printf "editor returned with non-zero exit status ~a" r))))364 ((ch)365 (history-clear)366 (##sys#void))367 ((h)368 (history-show)369 (##sys#void))370 ((c)371 (show-frameinfo selected-frame)372 (##sys#void))373 ((f)374 (select-frame (read))375 (##sys#void))376 ((g)377 (copy-from-frame (read)))378 ((s)379 (let* ((str (read-line))380 (r (system str)) )381 (history-add (list r))382 r) )383 ((?)384 (display385 "Toplevel commands:386387 ,? Show this text388 ,p EXP Pretty print evaluated expression EXP389 ,d EXP Describe result of evaluated expression EXP390 ,du EXP Dump data of expression EXP391 ,dur EXP N Dump range392 ,q Quit interpreter393 ,l FILENAME ... Load one or more files394 ,ln FILENAME ... Load one or more files and print result of each top-level expression395 ,r Show system information396 ,h Show history of expression results397 ,ch Clear history of expression results398 ,e FILENAME Run external editor399 ,s TEXT ... Execute shell-command400 ,exn Describe last exception401 ,c Show call-chain of most recent error402 ,f N Select frame N403 ,g NAME Get variable NAME from current frame404 ,t EXP Evaluate form and print elapsed time405 ,x EXP Pretty print expanded expression EXP\n")406 (for-each407 (lambda (a)408 (let ((help (caddr a)))409 (if help410 (print #\space help)411 (print " ," (car a)) ) ) )412 command-table)413 (##sys#void) )414 (else415 (printf "undefined toplevel command ~s - enter `,?' for help~%" form)416 (##sys#void) ) ) ) ) ) )417 (else418 (receive rs (eval form)419 (history-add rs)420 (apply values rs) ) ) ) ) ) )421422423;;; Builtin toplevel commands:424425(toplevel-command426 'm427 (let ((printf printf))428 (lambda ()429 (let ((name (read)))430 (cond ((not name)431 (##sys#switch-module #f)432 (printf "; resetting current module to toplevel~%"))433 ((##sys#find-module (##sys#resolve-module-name name #f) #f) =>434 (lambda (m)435 (##sys#switch-module m)436 (printf "; switching current module to `~a'~%" name)))437 (else438 (printf "undefined module `~a'~%" name))))))439 ",m MODULE switch to module with name `MODULE'")440441(toplevel-command442 'x1443 (let ((pretty-print pretty-print))444 (lambda ()445 (let ([expr (read)])446 ;; avoid bootstrapping issue, as chicken.syntax is not447 ;; imported dynamically by bootstrap compiler448 ;; this can be replaced by "expand1" later449 (pretty-print (strip-syntax (chicken.syntax#expand1 expr)))450 (##sys#void))))451 ",x1 EXP Pretty print expand1-ed expression EXP")452453454;;; Parse options from string:455456(define (parse-option-string str)457 (let ([ins (open-input-string str)])458 (map (lambda (o)459 (if (string? o)460 o461 (let ([os (open-output-string)])462 (write o os)463 (get-output-string os) ) ) )464 (handle-exceptions ex (##sys#error "invalid option syntax" str)465 (do ([x (read ins) (read ins)]466 [xs '() (cons x xs)] )467 ((eof-object? x) (reverse xs)) ) ) ) ) )468469470;;; Print status information:471472(define report473 (let ((printf printf)474 (sort sort)475 (with-output-to-port with-output-to-port)476 (current-output-port current-output-port)477 (argv argv)478 (prefix (foreign-value "C_INSTALL_PREFIX" c-string)))479 (lambda port480 (with-output-to-port (if (pair? port) (car port) (current-output-port))481 (lambda ()482 (gc)483 (let ((sinfo (##sys#symbol-table-info))484 (minfo (memory-statistics))485 (interrupts (foreign-value "C_interrupts_enabled" bool))486 (fixed-heap (foreign-value "C_heap_size_is_fixed" bool))487 (downward-stack (foreign-value "C_STACK_GROWS_DOWNWARD" bool)))488 (define (shorten n) (/ (truncate (* n 100)) 100))489 (printf "Features:~%~%")490 (let ((fs (sort (map keyword->string ##sys#features) string<?))491 (c 0))492 (for-each493 (lambda (f)494 (printf " ~a" f)495 (let* ((len (string-length f))496 (pad (- 16 len)))497 (set! c (add1 c))498 (when (<= pad 0)499 (set! c (add1 c))500 (set! pad (+ pad 18)))501 (cond ((>= c 3)502 (display "\n")503 (set! c 0))504 (else505 (display (make-string pad #\space))))))506 fs))507 (printf "~%~%~508 Machine type: \t~A (~A-bit)~%~509 Software type: \t~A~%~510 Software version:\t~A~%~511 Build platform: \t~A~%~512 Installation prefix:\t~A~%~513 Extension installation location:\t~A~%~514 Extension path: \t~A~%~515 Include path: \t~A~%~516 Keyword style: \t~A~%~517 Symbol-table load:\t~S~% ~518 Avg bucket length:\t~S~% ~519 Total symbol count:\t~S~%~520 Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~521 nursery size is ~S bytes, stack grows ~A~%~522 Command line: \t~S~%"523 (machine-type)524 (foreign-value "C_WORD_SIZE" int)525 (software-type)526 (software-version)527 (build-platform)528 prefix529 (installation-repository)530 (repository-path)531 ##sys#include-pathnames532 (keyword->string (keyword-style))533 (shorten (vector-ref sinfo 0))534 (shorten (vector-ref sinfo 1))535 (vector-ref sinfo 2)536 (vector-ref minfo 0)537 (if fixed-heap " (fixed)" "")538 (vector-ref minfo 1)539 (vector-ref minfo 2)540 (if downward-stack "downward" "upward")541 (argv))542 (##sys#write-char-0 #\newline ##sys#standard-output)543 (when interrupts (display "interrupts are enabled\n"))544 (##core#undefined) ) ) ) ) ) )545546547;;; Describe & dump:548549(define bytevector-data550 '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)551 (s8vector "vector of signed bytes" s8vector-length s8vector-ref)552 (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)553 (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)554 (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)555 (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)556 (u64vector "vector of unsigned 64-bit words" u64vector-length u64vector-ref)557 (s64vector "vector of signed 64-bit words" s64vector-length s64vector-ref)558 (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)559 (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref)560 (c64vector "vector of 32-bit complex numbers" c64vector-length c64vector-ref)561 (c128vector "vector of 64-bit complex numbers" c128vector-length c128vector-ref) ) )562563(define (circular-list? x)564 (let lp ((x x) (lag x))565 (and (pair? x)566 (let ((x (cdr x)))567 (and (pair? x)568 (let ((x (cdr x))569 (lag (cdr lag)))570 (or (eq? x lag) (lp x lag))))))))571572(define (improper-pairs? x)573 (let lp ((x x))574 (if (not (pair? x)) #f575 (or (eq? x (car x))576 (lp (cdr x))))))577578(define-constant max-describe-lines 40)579580(define describe581 (let ([sprintf sprintf]582 [printf printf]583 [fprintf fprintf]584 [length length]585 [list-ref list-ref]586 [string-ref string-ref])587 (lambda (x #!optional (out ##sys#standard-output))588 (define (descseq name plen pref start)589 (let ((len (fx- (plen x) start)))590 (when name (fprintf out "~A of length ~S~%" name len))591 (let loop1 ((i 0))592 (cond ((fx>= i len))593 ((fx>= i max-describe-lines)594 (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )595 (else596 (let ((v (pref x (fx+ start i))))597 (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))598 (cond ((fx>= j len)599 (##sys#with-print-length-limit600 1000601 (lambda ()602 (fprintf out " ~S: ~S" i v)))603 (if (fx> n 1)604 (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"605 (fx- n 1)606 (if (eq? n 2) "" "s"))607 (newline out) )608 (loop1 (fx+ i n)) )609 ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))610 (else (loop2 n len)) ) ) ) ) ) ) ) )611 (when (##sys#permanent? x)612 (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )613 (cond ((char? x)614 (let ([code (char->integer x)])615 (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) )616 ((eq? x #t) (fprintf out "boolean true~%"))617 ((eq? x #f) (fprintf out "boolean false~%"))618 ((null? x) (fprintf out "empty list~%"))619 ((bwp-object? x)620 (fprintf out "broken weak pointer~%"))621 ((eof-object? x) (fprintf out "end-of-file object~%"))622 ((eq? (##sys#void) x) (fprintf out "unspecified object~%"))623 ((fixnum? x)624 (fprintf out "exact immediate integer ~S~% #x~X~% #o~O~% #b~B"625 x x x x)626 (let ([code (integer->char x)])627 (when (fx< x #x10000) (fprintf out ", character ~S" code)) )628 (##sys#write-char-0 #\newline ##sys#standard-output) )629 ((bignum? x)630 (fprintf out "exact large integer ~S~% #x~X~% #o~O~% #b~B~%"631 x x x x) )632 ((##core#inline "C_unboundvaluep" x)633 (fprintf out "unbound value~%"))634 ((flonum? x) (fprintf out "inexact rational number ~S~%" x))635 ((ratnum? x) (fprintf out "exact ratio ~S~%" x))636 ((cplxnum? x) (fprintf out "~A complex number ~S~%"637 (if (exact? x) "exact" "inexact") x))638 ((number? x) (fprintf out "number ~S~%" x))639 ((string? x) (descseq "string" string-length string-ref 0))640 ((vector? x) (descseq "vector" ##sys#size ##sys#slot 0))641 ((keyword? x)642 (fprintf out "keyword symbol with name ~s~%"643 (##sys#symbol->string/shared x)))644 ((symbol? x)645 (unless (##sys#symbol-has-toplevel-binding? x)646 (display "unbound " out))647 (fprintf out "~asymbol with name ~S~%"648 (if (##sys#interned-symbol? x) "" "uninterned ")649 (##sys#symbol->string/shared x))650 (let ((plist (##sys#slot x 2)))651 (unless (null? plist)652 (display " \nproperties:\n\n" out)653 (do ((plist plist (cddr plist)))654 ((null? plist))655 (fprintf out " ~s\t" (car plist))656 (##sys#with-print-length-limit657 1000658 (lambda ()659 (write (cadr plist) out) ) )660 (newline out) ) ) ) )661 ((or (circular-list? x) (improper-pairs? x))662 (fprintf out "circular structure: ")663 (let loop-print ((x x)664 (cdr-refs (list x)))665 (cond ((or (atom? x)666 (null? x)) (printf "eol~%"))667 ((memq (car x) cdr-refs)668 (fprintf out "(circle)~%" ))669 ((not (memq (car x) cdr-refs))670 (fprintf out "~S -> " (car x))671 (loop-print (cdr x) (cons (car x) cdr-refs) )))))672 ((list? x) (descseq "list" length list-ref 0))673 ((pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x)))674 ((procedure? x)675 (let ([len (##sys#size x)])676 (descseq677 (sprintf "procedure with code pointer 0x~X" (##sys#peek-unsigned-integer x 0))678 ##sys#size ##sys#slot 1) ) )679 ((port? x)680 (fprintf out681 "~A port of type ~A with name ~S and ~A encoding~%"682 (if (##sys#slot x 1) "input" "output")683 (##sys#slot x 7)684 (##sys#slot x 3)685 (##sys#slot x 15) ) )686 ((not (##core#inline "C_blockp" x))687 ;; catch immediates here, as ##sys#locative? crashes on non-block688 (fprintf out "unknown immediate object~%"))689 ((##sys#locative? x)690 (fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"691 (##sys#peek-unsigned-integer x 0)692 (##sys#slot x 1)693 (case (##sys#slot x 2)694 ((0) "slot")695 ((1) "char")696 ((2) "u8vector")697 ((3) "s8vector")698 ((4) "u16vector")699 ((5) "s16vector")700 ((6) "u32vector")701 ((7) "s32vector")702 ((8) "u64vector")703 ((9) "s64vector")704 ((10) "f32vector")705 ((11) "f64vector") ) ) )706 ((##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0)))707 ((##sys#bytevector? x)708 (let ([len (##sys#size x)])709 (fprintf out "bytevector of size ~S:~%" len)710 (hexdump x len ##sys#byte out) ) )711 ((##core#inline "C_lambdainfop" x)712 (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) )713 ((##sys#structure? x 'hash-table)714 (let ((n (##sys#slot x 2)))715 (fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"716 n (if (fx= n 1) "" "s") (##sys#slot x 3)) )717 (fprintf out " hash function: ~a~%" (##sys#slot x 4))718 ;; this copies code out of srfi-69.scm, but we don't want to depend on it719 (let* ((vec (##sys#slot x 1))720 (len (##sys#size vec)) )721 (do ((i 0 (fx+ i 1)) )722 ((fx>= i len))723 (for-each724 (lambda (bucket)725 (fprintf out " ~S\t-> ~S~%"726 (##sys#slot bucket 0) (##sys#slot bucket 1)) )727 (##sys#slot vec i)) ) ) )728 ((##sys#structure? x 'condition)729 (fprintf out "condition: ~s~%" (##sys#slot x 1))730 (for-each731 (lambda (k)732 (fprintf out " ~s~%" k)733 (let loop ((props (##sys#slot x 2)))734 (unless (null? props)735 (when (eq? k (caar props))736 (##sys#with-print-length-limit737 100738 (lambda ()739 (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))740 (newline out))741 (loop (cddr props)) ) ) )742 (##sys#slot x 1) ) )743 ((##sys#generic-structure? x)744 (let ((st (##sys#slot x 0)))745 (cond ((assq st bytevector-data) =>746 (lambda (data)747 (apply descseq (append (map eval (cdr data)) (list 0)))) )748 (else749 (fprintf out "structure of type `~S':~%" (##sys#slot x 0))750 (descseq #f ##sys#size ##sys#slot 1) ) ) ) )751 (else (fprintf out "unknown object~%")) )752 (##sys#void) ) ) )753754755;;; Display hexdump:756757(define dump758 (lambda (x . len-out)759 (let-optionals len-out760 ([len #f]761 [out ##sys#standard-output] )762 (define (bestlen n) (if len (min len n) n))763 (cond [(##sys#immediate? x) (##sys#error 'dump "cannot dump immediate object" x)]764 [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]765 [(string? x)766 (let ((bv (##sys#slot x 0)))767 (hexdump bv (bestlen (fx- (##sys#size bv) 1)) ##sys#byte out))]768 [(and (not (##sys#immediate? x)) (##sys#pointer? x))769 (hexdump x 32 ##sys#peek-byte out) ]770 [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))771 (let ([bv (##sys#slot x 1)])772 (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]773 [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )774775(define hexdump776 (let ([display display]777 [string-append string-append]778 [make-string make-string]779 [write-char write-char] )780 (lambda (bv len ref out)781782 (define (justify n m base lead)783 (let* ([s (number->string n base)]784 [len (string-length s)] )785 (if (fx< len m)786 (string-append (make-string (fx- m len) lead) s)787 s) ) )788789 (do ([a 0 (fx+ a 16)])790 ((fx>= a len))791 (display (justify a 4 10 #\space) out)792 (write-char #\: out)793 (do ([j 0 (fx+ j 1)]794 [a a (fx+ a 1)] )795 ((or (fx>= j 16) (fx>= a len))796 (when (fx>= a len)797 (let ((o (fxmod len 16)))798 (unless (fx= o 0)799 (do ((k (fx- 16 o) (fx- k 1)))800 ((fx= k 0))801 (display " " out) ) ) ) ) )802 (write-char #\space out)803 (display (justify (ref bv a) 2 16 #\0) out) )804 (write-char #\space out)805 (do ([j 0 (fx+ j 1)]806 [a a (fx+ a 1)] )807 ((or (fx>= j 16) (fx>= a len)))808 (let ([c (ref bv a)])809 (if (and (fx>= c 32) (fx< c 128))810 (write-char (integer->char c) out)811 (write-char #\. out) ) ) )812 (write-char #\newline out) ) ) ) )813814815;;; Frame-info operations:816817(define show-frameinfo818 (let ((newline newline)819 (display display))820 (lambda (fn)821 (define (prin1 x)822 (##sys#with-print-length-limit823 100824 (lambda ()825 (##sys#print x #t ##sys#standard-output))))826 (let* ((ct (or ##sys#repl-recent-call-chain '()))827 (len (length ct)))828 (set! selected-frame829 (or (and (memq fn ct) fn)830 (and (fx> len 0)831 (list-ref ct (fx- len 1)))))832 (do ((ct ct (cdr ct))833 (i (fx- len 1) (fx- i 1)))834 ((null? ct))835 (let* ((info (car ct))836 (here (eq? selected-frame info))837 (form (##sys#slot info 1)) ; cooked1 (expr/form)838 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)839 (finfo (##sys#structure? data 'frameinfo))840 (cntr (if finfo (##sys#slot data 1) data))) ; cntr841 (printf "~a~a:~a\t~a\t "842 (if here #\* #\space)843 i844 (if (and finfo (pair? (##sys#slot data 2))) "[]" " ") ; e845 (##sys#slot info 0)) ; raw846 (when cntr (printf "[~a] " cntr))847 (when form (prin1 form))848 (newline)849 (when (and here finfo)850 (for-each851 (lambda (e v)852 (unless (null? e)853 (display " ---\n")854 (do ((i 0 (fx+ i 1))855 (be e (cdr be)))856 ((null? be))857 (printf " ~s:\t " (car be))858 (prin1 (##sys#slot v i))859 (newline))))860 (##sys#slot data 2) ; e861 (##sys#slot data 3))))))))) ; v862863(define select-frame864 (let ((display display))865 (lambda (n)866 (cond ((or (not (number? n))867 (not ##sys#repl-recent-call-chain)868 (fx< n 0)869 (fx>= n (length ##sys#repl-recent-call-chain)))870 (display "no such frame\n"))871 (else872 (set! selected-frame873 (list-ref874 ##sys#repl-recent-call-chain875 (fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))876 (show-frameinfo selected-frame))))))877878(define copy-from-frame879 (let ((display display)880 (newline newline)881 (call/cc call-with-current-continuation))882 (lambda (name)883 (let* ((ct (or ##sys#repl-recent-call-chain '()))884 (len (length ct))885 (name886 (cond ((symbol? name) (##sys#slot name 1)) ; name887 ((string? name) name)888 (else889 (display "string or symbol required for `,g'\n")890 #f))))891 (define (compare sym)892 (let ((str (##sys#slot sym 1))) ; name893 (string=?894 name895 (substring str 0 (min (string-length name) (string-length str))))))896 (if name897 (call/cc898 (lambda (return)899 (define (fail msg)900 (display msg)901 (newline)902 (return (##sys#void)))903 (do ((ct ct (cdr ct)))904 ((null? ct) (fail "no environment in frame"))905 ;;XXX this should be refactored as it duplicates the code above906 (let* ((info (car ct))907 (here (eq? selected-frame info))908 (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)909 (finfo (##sys#structure? data 'frameinfo)))910 (when (and here finfo)911 (for-each912 (lambda (e v)913 (do ((i 0 (fx+ i 1))914 (be e (cdr be)))915 ((null? be))916 (when (compare (car be))917 (display "; getting ")918 (display (car be))919 (newline)920 (history-add (list (##sys#slot v i)))921 (return (##sys#slot v i)))))922 (##sys#slot data 2) ; e923 (##sys#slot data 3)) ; v924 (fail (##sys#string-append "no such variable: " name)))))))925 (##sys#void))))))926927928;;; Handle some signals:929930(define-foreign-variable _sigint int "SIGINT")931932(define-syntax defhandler933 (syntax-rules ()934 ((_ sig handler)935 (begin936 (##core#inline "C_establish_signal_handler" sig sig)937 (##sys#setslot ##sys#signal-vector sig handler)))))938939(defhandler _sigint (lambda (n) (##sys#user-interrupt-hook)))940941942;;; Start interpreting:943944(define (member* keys set)945 (let loop ((set set))946 (and (pair? set)947 (let find ((ks keys))948 (cond ((null? ks) (loop (cdr set)))949 ((equal? (car ks) (car set)) set)950 (else (find (cdr ks))) ) ) ) ) )951952(define-constant short-options953 '(#\k #\s #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P #\K) )954955(define-constant long-options956 '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-no-feature" "-eval"957 "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"958 "-r7rs-syntax" "-setup-mode"959 "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"960 "-include-path" "-release" "-print" "-pretty-print" "--") )961962(define (canonicalize-args args)963 (let loop ((args args))964 (if (null? args)965 '()966 (let ((x (car args)))967 (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)968 ((and (fx= (string-length x) 2)969 (char=? #\- (string-ref x 0)))970 (if (memq (string-ref x 1) short-options)971 (cons x (loop (cdr args)))972 (##sys#error "invalid option" x)))973 ((and (fx> (string-length x) 2)974 (char=? #\- (string-ref x 0))975 (not (member x long-options)) )976 (if (char=? #\: (string-ref x 1))977 (loop (cdr args))978 (let ((cs (string->list (substring x 1))))979 (if (findall cs short-options)980 (append (map (cut string #\- <>) cs) (loop (cdr args)))981 (##sys#error "invalid option" x) ) ) ) )982 (else (cons x (loop (cdr args)))))))))983984(define (findall chars clist)985 (let loop ((chars chars))986 (or (null? chars)987 (and (memq (car chars) clist)988 (loop (cdr chars))))))989990(define-constant simple-options991 '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"992 "-i" "-case-insensitive"993 "-no-parentheses-synonyms" "-r7rs-syntax" "-setup-mode"994 ; Not "simple" but processed early995 "-ss" "-sx" "-s" "-script") )996997(define-constant complex-options998 '("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )9991000(define (string-trim str)1001 (let loop ((front 0)1002 (back (string-length str)))1003 (cond ((= front back) "")1004 ((char-whitespace? (string-ref str front))1005 (loop (add1 front) back))1006 ((char-whitespace? (string-ref str (sub1 back)))1007 (loop front (sub1 back)))1008 (else (substring str front back)))))10091010(define (string->extension-name str)1011 (let ((str (string-trim str)))1012 (if (and (positive? (string-length str))1013 (char=? #\( (string-ref str 0)))1014 (handle-exceptions ex1015 (##sys#error "invalid import specification" str)1016 (with-input-from-string str read))1017 (string->symbol str))))10181019(define (run)1020 (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]1021 [args (canonicalize-args (command-line-arguments))]1022 ; Check for these before 'args' is updated by any 'extraopts'1023 [kwstyle (member* '("-K" "-keyword-style") args)]1024 [script (member* '("-ss" "-sx" "-s" "-script") args)])1025 (cond [script1026 (when (or (not (pair? (cdr script)))1027 (zero? (string-length (cadr script)))1028 (char=? #\- (string-ref (cadr script) 0)) )1029 (##sys#error "missing or invalid script argument"))1030 (program-name (cadr script))1031 (command-line-arguments (cddr script))1032 ;; 2012-10-04 (felix) left 'script activated to avoid breaking too much code1033 (register-feature! 'chicken-script)1034 (set-cdr! (cdr script) '())1035 (when ##sys#windows-platform1036 (and-let* ((sname (lookup-script-file (cadr script))))1037 (set-car! (cdr script) sname) ) ) ]1038 [else1039 (set! args (append (canonicalize-args extraopts) args))1040 (and-let* ([p (member "--" args)])1041 (set-cdr! p '()) ) ] )1042 (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]1043 [batch (or script (member* '("-b" "-batch") args) eval?)]1044 [quietflag (member* '("-q" "-quiet") args)]1045 [quiet (or script quietflag eval?)])1046 (define (collect-options opt)1047 (let loop ([opts args])1048 (cond [(member opt opts)1049 => (lambda (p)1050 (if (null? (cdr p))1051 (##sys#error "missing argument to command-line option" opt)1052 (cons (cadr p) (loop (cddr p)))) ) ]1053 [else '()] ) ) )1054 (define (loadinit)1055 (let* ((sys-dir (system-config-directory))1056 (cfg-fn (and sys-dir (make-pathname (list sys-dir "chicken")1057 init-file)))1058 (home (get-environment-variable "HOME"))1059 (home-fn (and home (not (string=? home ""))1060 (make-pathname home (string-append "." init-file)))))1061 (cond ((and cfg-fn (file-exists? cfg-fn))1062 (load cfg-fn))1063 ((and home-fn (file-exists? home-fn))1064 (load home-fn) ) ) ) )1065 (define (evalstring str #!optional (rec (lambda _ (void))))1066 (let ((in (open-input-string str))1067 (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing1068 (do ([x (read-with-source-info in) (read-with-source-info in)])1069 ((eof-object? x))1070 (rec (receive (eval x))) ) ) )1071 (when (member* '("-h" "-help" "--help") args)1072 (print-usage)1073 (exit 0) )1074 (when (member "-version" args)1075 (print-banner)1076 (exit 0) )1077 (when (member "-setup-mode" args)1078 (set! ##sys#setup-mode #t))1079 (when (member "-release" args)1080 (print (chicken-version))1081 (exit 0) )1082 (when (member* '("-w" "-no-warnings") args)1083 (unless quiet (display "Warnings are disabled\n"))1084 (set! ##sys#warnings-enabled #f) )1085 (when (member* '("-i" "-case-insensitive") args)1086 (unless quiet (display "Identifiers and symbols are case insensitive\n"))1087 (register-feature! 'case-insensitive)1088 (case-sensitive #f) )1089 (for-each register-feature! (collect-options "-feature"))1090 (for-each register-feature! (collect-options "-D"))1091 (for-each unregister-feature! (collect-options "-no-feature"))1092 (set! ##sys#include-pathnames1093 (delete-duplicates1094 (append (map chop-separator (collect-options "-include-path"))1095 (map chop-separator (collect-options "-I"))1096 ##sys#include-pathnames)1097 string=?) )1098 (when kwstyle1099 (cond [(not (pair? (cdr kwstyle)))1100 (##sys#error "missing argument to `-keyword-style' option") ]1101 [(string=? "prefix" (cadr kwstyle))1102 (keyword-style #:prefix) ]1103 [(string=? "none" (cadr kwstyle))1104 (keyword-style #:none) ]1105 [(string=? "suffix" (cadr kwstyle))1106 (keyword-style #:suffix) ] ) )1107 (when (member* '("-no-parentheses-synonyms") args)1108 (unless quiet (display "Disabled support for parentheses synonyms\n"))1109 (parentheses-synonyms #f) )1110 (when (member* '("-r7rs-syntax") args)1111 (unless quiet (display "Disabled the CHICKEN extensions to R7RS syntax\n"))1112 (case-sensitive #f)1113 (keyword-style #:none)1114 (parentheses-synonyms #f) )1115 ;; Load the the default modules into the evaluation environment.1116 ;; This is done before setting load-verbose => #t to avoid1117 ;; spurious import messages.1118 (eval `(import-for-syntax ,@default-syntax-imports))1119 (eval `(import ,@default-imports))1120 (unless quiet1121 (load-verbose #t)1122 (print-banner)1123 (print "Type ,? for help."))1124 (unless (or (member* '("-n" "-no-init") args) script eval?)1125 (loadinit))1126 (when batch1127 (set! ##sys#notices-enabled #f))1128 (do ([args args (cdr args)])1129 ((null? args)1130 (register-repl-history!)1131 (unless batch1132 (repl default-evaluator)1133 (##sys#write-char-0 #\newline ##sys#standard-output) ) )1134 (let* ((arg (car args)))1135 (cond ((member arg simple-options))1136 ((member arg complex-options)1137 (set! args (cdr args)) )1138 ((or (string=? "-R" arg) (string=? "-require-extension" arg))1139 (eval `(import ,(string->extension-name (cadr args))))1140 (set! args (cdr args)) )1141 ((or (string=? "-e" arg) (string=? "-eval" arg))1142 (evalstring (cadr args))1143 (set! args (cdr args)) )1144 ((or (string=? "-p" arg) (string=? "-print" arg))1145 (evalstring (cadr args) (cut for-each print <...>))1146 (set! args (cdr args)) )1147 ((or (string=? "-P" arg) (string=? "-pretty-print" arg))1148 (evalstring (cadr args) (cut for-each pretty-print <...>) )1149 (set! args (cdr args)) )1150 (else1151 (let ((scr (and script (car script))))1152 (load1153 arg1154 (and (equal? "-sx" scr)1155 (lambda (x)1156 (let* ((str (with-output-to-string (cut pretty-print x)))1157 (len (string-length str)))1158 (flush-output ##sys#standard-output)1159 (display "\n; " ##sys#standard-error)1160 (do ((i 0 (fx+ i 1)))1161 ((fx>= i len))1162 (let ((c (string-ref str i)))1163 (write-char c ##sys#standard-error)1164 (when (char=? #\newline c)1165 (display "; " ##sys#standard-error))))1166 (newline ##sys#standard-error)1167 (eval x)))))1168 (when (equal? "-ss" scr)1169 (receive rs ((eval 'main) (command-line-arguments))1170 (let ((r (optional rs)))1171 (exit (if (fixnum? r) r 0)))))))))))))11721173(run))