source: project/chicken/branches/prerelease/csi.scm @ 15229

Last change on this file since 15229 was 15229, checked in by felix, 10 years ago

(really) merged trunk changes till 15228 into prerelease branch

File size: 34.0 KB
Line 
1;;;; csi.scm - Interpreter stub for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     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 promote
15;     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 EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (uses chicken-syntax srfi-69 ports) ; is here because a bootstrap from an older chicken may not make
30  (usual-integrations)                  ;  this used automatically
31  (disable-interrupts)
32  (disable-warning var)
33  (run-time-macros)                     ;*** later: compile-syntax
34  (foreign-declare #<<EOF
35#if (defined(_MSC_VER) && defined(_WIN32)) || defined(HAVE_DIRECT_H)
36# include <direct.h>
37#else
38# define _getcwd(buf, len)       NULL
39#endif
40EOF
41) )
42
43(include "banner")
44
45(private csi 
46  print-usage print-banner
47  run hexdump del 
48  parse-option-string chop-separator lookup-script-file
49  report describe dump hexdump bytevector-data get-config
50  deldups tty-input?
51  history-list history-count history-add history-ref
52  trace-indent trace-indent-level traced-procedure-entry traced-procedure-exit)
53
54(declare
55  (always-bound
56    ##sys#windows-platform)
57  (hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
58        traced-procedures describer-table dirseparator? resolve-var
59        findall trace-indent command-table do-break do-unbreak broken-procedures) )
60
61
62;;; Parameters:
63
64(define-constant init-file ".csirc")
65
66(set! ##sys#repl-print-length-limit 2048)
67(set! ##sys#features (cons #:csi ##sys#features))
68
69
70;;; Print all sorts of information:
71
72(define (print-usage)
73  (display #<<EOF
74usage: csi [FILENAME | OPTION ...]
75
76  `csi' is the CHICKEN interpreter.
77 
78  FILENAME is a Scheme source file name with optional extension. OPTION may be
79  one of the following:
80
81    -h  -help  --help             display this text and exit
82    -v  -version                  display version and exit
83        -release                  print release number and exit
84    -i  -case-insensitive         enable case-insensitive reading
85    -e  -eval EXPRESSION          evaluate given expression
86    -p  -print EXPRESSION         evaluate and print result(s)
87    -P  -pretty-print EXPRESSION  evaluate and print result(s) prettily
88    -D  -feature SYMBOL           register feature identifier
89    -q  -quiet                    do not print banner
90
91EOF
92)
93  (display #<#EOF
94    -n  -no-init                  do not load initialization file #{#\`} #{init-file} #{#\'}
95
96EOF
97)
98  (display  #<<EOF
99    -b  -batch                    terminate after command-line processing
100    -w  -no-warnings              disable all warnings
101    -k  -keyword-style STYLE      enable alternative keyword-syntax
102                                   (prefix, suffix or none)
103        -no-parentheses-synonyms  disables list delimiter synonyms
104        -no-symbol-escape         disables support for escaped symbols
105        -r5rs-syntax              disables the Chicken extensions to
106                                   R5RS syntax
107    -s  -script PATHNAME          use interpreter for shell scripts
108        -ss PATHNAME              shell script with `main' procedure
109        -sx PATHNAME              same as `-s', but print each expression
110                                   as it is evaluated
111    -R  -require-extension NAME   require extension and import before
112                                   executing code
113    -I  -include-path PATHNAME    add PATHNAME to include path
114    --                            ignore all following options
115
116EOF
117) )
118
119(define (print-banner)
120  (newline)
121  #; ;UNUSED
122  (when (and (tty-input?) (##sys#fudge 11))
123    (let* ((t (string-copy +product+))
124           (len (string-length t))
125           (c (make-string len #\x08)))
126      (do ((i (sub1 (* 2 len)) (sub1 i)))
127          ((zero? i))
128        (let* ((p (abs (- i len)))
129               (o (string-ref t p)))
130          (string-set! t p #\@)
131          (print* t)
132          (string-set! t p o)
133          (let ((t0 (+ (current-milliseconds) 20)))
134            (let loop ()                ; crude, but doesn't need srfi-18
135              (when (< (current-milliseconds) t0)
136                (loop))))
137          (print* c) ) ) ) )
138  (print +product+)
139  (print +banner+ (chicken-version #t) "\n") )
140
141
142;;; Reader for REPL history:
143
144(set! ##sys#user-read-hook
145  (let ([read-char read-char]
146        [read read]
147        [old-hook ##sys#user-read-hook] )
148    (lambda (char port)
149      (cond [(or (char=? #\) char) (char-whitespace? char))
150             `',(history-ref (fx- history-count 1)) ]
151            [else (old-hook char port)] ) ) ) )
152
153(set! ##sys#sharp-number-hook
154  (lambda (port n)
155    `',(history-ref n) ) )
156
157
158;;; Chop terminating separator from pathname:
159
160(define (dirseparator? c)
161  (or (char=? c #\\) (char=? c #\/)))
162
163(define chop-separator 
164  (let ([substring substring] )
165    (lambda (str)
166      (let* ((len (sub1 (##sys#size str)))
167             (c (string-ref str len)))
168        (if (and (fx> len 0) (dirseparator? c))
169            (substring str 0 len)
170            str) ) ) ) )
171
172
173;;; Find script in PATH (only used for Windows/DOS):
174
175(define @ #f)
176
177(define lookup-script-file 
178  (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          name
183          (let ([n2 (string-append name ".bat")])
184            (and (file-exists? n2) n2) ) ) )
185    (define (string-index proc str1)
186      (let ((len (##sys#size str1)))
187        (let loop ((i 0))
188          (cond ((fx>= i len) #f)
189                ((proc (##core#inline "C_subchar" str1 i)) i)
190                (else (loop (fx+ i 1))) ) ) ) )
191    (lambda (name)
192      (let ([path (get-environment-variable "PATH")])
193        (and (> (##sys#size name) 0)
194             (cond [(dirseparator? (string-ref name 0)) (addext name)]
195                   [(string-index dirseparator? name)
196                    (and-let* ([p (_getcwd buf 256)])
197                      (addext (string-append (chop-separator p) "/" name)) ) ]
198                   [(addext name)]
199                   [else
200                    (let ([name2 (string-append "/" name)])
201                      (let loop ([ps (string-split 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)) ) ) ) ) ) ] ) ) ) ) ) )
206                                   
207
208;;; REPL customization:
209
210(define history-list (make-vector 32))
211(define history-count 1)
212
213(define history-add
214  (let ([vector-resize vector-resize])
215    (lambda (vals)
216      (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]
217            [size (##sys#size history-list)] )
218        (when (fx>= history-count size)
219          (set! history-list (vector-resize history-list (fx* 2 size))) )
220        (vector-set! history-list history-count x)
221        (set! history-count (fx+ history-count 1))
222        x) ) ) )
223
224(define (history-ref index)
225  (let ([i (inexact->exact index)])
226    (if (and (fx> i 0) (fx<= i history-count))
227        (vector-ref history-list i) 
228        (##sys#error "history entry index out of range" index) ) ) )
229
230(repl-prompt
231 (let ([sprintf sprintf])
232   (lambda ()
233     (sprintf "#;~A> " history-count) ) ) )
234
235(define (tty-input?)
236  (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) )
237
238(set! ##sys#break-on-error #f)
239
240(set! ##sys#read-prompt-hook
241  (let ([old ##sys#read-prompt-hook])
242    (lambda ()
243      (when (tty-input?) (old)) ) ) )
244
245(define command-table (make-vector 37 '()))
246
247(define (toplevel-command name proc #!optional help)
248  (##sys#check-symbol name 'toplevel-command)
249  (when help (##sys#check-string help 'toplevel-command))
250  (##sys#hash-table-set! command-table name (cons proc help)) )
251
252(set! ##sys#repl-eval-hook
253  (let ((eval eval)
254        (load-noisily load-noisily)
255        (read read)
256        (singlestep singlestep)
257        (read-line read-line)
258        (length length)
259        (display display)
260        (write write)
261        (string-split string-split)
262        (printf printf)
263        (expand expand)
264        (pretty-print pretty-print)
265        (integer? integer?)
266        (values values) )
267    (lambda (form)
268      (set! trace-indent-level 0)
269      (cond ((eof-object? form) (exit))
270            ((and (pair? form)
271                  (eq? 'unquote (##sys#slot form 0)) )
272             (let ((cmd (cadr form)))
273               (cond ((and (symbol? cmd) (##sys#hash-table-ref command-table cmd)) =>
274                      (lambda (p)
275                        ((car p))
276                        (##sys#void) ) )
277                     (else
278                      (case cmd
279                        ((x)
280                         (let ([x (read)])
281                           (pretty-print (##sys#strip-syntax (expand x)))
282                           (##sys#void) ) )
283                        ((p)
284                         (let* ([x (read)]
285                                [xe (eval x)] )
286                           (pretty-print xe)
287                           (##sys#void) ) )
288                        ((d)
289                         (let* ([x (read)]
290                                [xe (eval x)] )
291                           (describe xe) ) )
292                        ((du)
293                         (let* ([x (read)]
294                                [xe (eval x)] )
295                           (dump xe) ) )
296                        ((dur)
297                         (let* ([x (read)]
298                                [n (read)]
299                                [xe (eval x)] 
300                                [xn (eval n)] )
301                           (dump xe xn) ) )
302                        ((r) (report))
303                        ((q) (exit))
304                        ((l)
305                         (let ((fns (string-split (read-line))))
306                           (for-each load fns)
307                           (##sys#void) ) )
308                        ((ln) 
309                         (let ((fns (string-split (read-line))))
310                           (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)
311                           (##sys#void) ) )
312                        ((t)
313                         (let ((x (read)))
314                           (receive rs (time (eval x))
315                             (history-add rs)
316                             (apply values rs) ) ) )
317                        ((tr) (do-trace (map resolve-var (string-split (read-line)))))
318                        ((utr) (do-untrace (map resolve-var (string-split (read-line)))))
319                        ((br) (do-break (map resolve-var (string-split (read-line)))))
320                        ((ubr) (do-unbreak (map resolve-var (string-split (read-line)))))
321                        ((uba) (do-unbreak-all))
322                        ((breakall) 
323                         (set! ##sys#break-in-thread #f) ) 
324                        ((breakonly)
325                         (set! ##sys#break-in-thread (eval (read))) )
326                        ((info)
327                         (when (pair? traced-procedures)
328                           (printf "Traced: ~s~%" (map car traced-procedures)) )
329                         (when (pair? broken-procedures)
330                           (printf "Breakpoints: ~s~%" (map car broken-procedures)) ) )
331                        ((c)
332                         (cond (##sys#last-breakpoint
333                                (let ((exn ##sys#last-breakpoint))
334                                  (set! ##sys#last-breakpoint #f)
335                                  (##sys#break-resume exn) ) )
336                               (else (display "no breakpoint pending\n") ) ) )
337                        ((exn) 
338                         (when ##sys#last-exception
339                           (history-add (list ##sys#last-exception))
340                           (describe ##sys#last-exception) ) )
341                        ((step)
342                         (let ((x (read)))
343                           (read-line)
344                           (singlestep (eval `(lambda () ,x))) ) )
345                        ((s)
346                         (let* ((str (read-line))
347                                (r (system str)) )
348                           (history-add (list r))
349                           r) )
350                        ((?)
351                         (display
352                          "Toplevel commands:
353
354 ,?                Show this text
355 ,p EXP            Pretty print evaluated expression EXP
356 ,d EXP            Describe result of evaluated expression EXP
357 ,du EXP           Dump data of expression EXP
358 ,dur EXP N        Dump range
359 ,q                Quit interpreter
360 ,l FILENAME ...   Load one or more files
361 ,ln FILENAME ...  Load one or more files and print result of each top-level expression
362 ,r                Show system information
363 ,s TEXT ...       Execute shell-command
364 ,tr NAME ...      Trace procedures
365 ,utr NAME ...     Untrace procedures
366 ,br NAME ...      Set breakpoints
367 ,ubr NAME ...     Remove breakpoints
368 ,uba              Remove all breakpoints
369 ,breakall         Break in all threads (default)
370 ,breakonly THREAD Break only in specified thread
371 ,c                Continue from breakpoint
372 ,info             List traced procedures and breakpoints
373 ,step EXPR        Execute EXPR in single-stepping mode
374 ,exn              Describe last exception
375 ,t EXP            Evaluate form and print elapsed time
376 ,x EXP            Pretty print expanded expression EXP\n")
377                         (##sys#hash-table-for-each
378                          (lambda (k v) 
379                            (let ((help (cdr v)))
380                              (if help
381                                  (print #\space help)
382                                  (print " ," k) ) ) )
383                          command-table)
384                         (##sys#void) )
385                        (else
386                         (printf "Undefined toplevel command ~s - enter `,?' for help~%" form) 
387                         (##sys#void) ) ) ) ) ) )
388            (else
389             (receive rs (eval form)
390               (history-add rs)
391               (apply values rs) ) ) ) ) ) )
392
393(define (resolve-var str)
394  (##sys#strip-syntax (string->symbol str) (##sys#current-environment) #t))
395
396
397;;; Tracing:
398
399(define (del x lst tst)
400  (let loop ([lst lst])
401    (if (null? lst)
402        '()
403        (let ([y (car lst)])
404          (if (tst x y)
405              (cdr lst)
406              (cons y (loop (cdr lst))) ) ) ) ) )
407
408(define trace-indent-level 0)
409(define traced-procedures '())
410(define broken-procedures '())
411
412(define trace-indent
413  (lambda ()
414    (write-char #\|)
415    (do ((i trace-indent-level (sub1 i)))
416        ((<= i 0))
417      (write-char #\space) ) ) )
418
419(define traced-procedure-entry
420  (lambda (name args)
421    (trace-indent)
422    (set! trace-indent-level (add1 trace-indent-level))
423    (write (cons name args))
424    (##sys#write-char-0 #\newline ##sys#standard-output) 
425    (flush-output) ) )
426
427(define traced-procedure-exit
428  (lambda (name results)
429    (set! trace-indent-level (sub1 trace-indent-level))
430    (trace-indent)
431    (write name)
432    (display " -> ")
433    (for-each
434     (lambda (x)
435       (write x)
436       (write-char #\space) )
437     results)
438    (##sys#write-char-0 #\newline ##sys#standard-output) 
439    (flush-output) ) )
440
441(define do-trace
442  (lambda (names)
443    (if (null? names)
444        (for-each (lambda (a) (print (car a))) traced-procedures) 
445        (for-each
446         (lambda (s)
447           (let ((s (expand s)))
448             (cond ((assq s traced-procedures)
449                    (##sys#warn "procedure already traced" s) )
450                   ((assq s broken-procedures)
451                    (##sys#warn "procedure already has breakpoint") )
452                   (else
453                    (let ((old (##sys#slot s 0)))
454                      (cond ((not (procedure? old)) (##sys#error "cannot trace non-procedure" s))
455                            (else
456                             (set! traced-procedures (cons (cons s old) traced-procedures))
457                             (##sys#setslot
458                              s 0
459                              (lambda args
460                                (traced-procedure-entry s args)
461                                (call-with-values (lambda () (apply old args))
462                                  (lambda results
463                                    (traced-procedure-exit s results) 
464                                    (apply values results) ) ) ) ) ) ) ) ) ) ) )
465         names) ) ) )
466
467(define do-untrace 
468  (lambda (names)
469    (for-each
470     (lambda (s)
471       (let* ((s (expand s))
472              (p (assq s traced-procedures)) )
473         (cond ((not p) (##sys#warn "procedure not traced" s))
474               (else
475                (##sys#setslot s 0 (cdr p))
476                (set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
477     names) ) )
478
479(define do-break
480  (lambda (names)
481    (if (null? names)
482        (for-each (lambda (b) (print (car a))) broken-procedures) 
483        (for-each
484         (lambda (s)
485           (let* ((s (expand s))
486                  (a (assq s traced-procedures)))
487             (when a
488               (##sys#warn "un-tracing procedure" s)
489               (##sys#setslot s 0 (cdr a))
490               (set! traced-procedures (del a traced-procedures eq?)) )
491             (let ((old (##sys#slot s 0)))
492               (cond ((not (procedure? old)) (##sys#error "cannot set breakpoint on non-procedure" s))
493                     (else
494                      (set! broken-procedures (cons (cons s old) broken-procedures))
495                      (##sys#setslot
496                       s 0
497                       (lambda args
498                         (##sys#break-entry s args)
499                         (##sys#apply old args) ) ) ) ) ) ) )
500         names) ) ) )
501
502(define do-unbreak
503  (lambda (names)
504    (for-each
505     (lambda (s)
506       (let* ((s (expand s))
507              (p (assq s broken-procedures)) )
508         (cond ((not p) (##sys#warn "procedure has no breakpoint" s))
509               (else
510                (##sys#setslot s 0 (cdr p))
511                (set! broken-procedures (del p broken-procedures eq?) ) ) ) ) )
512     names) ) )
513
514(define do-unbreak-all
515  (lambda ()
516    (for-each (lambda (bp)
517                (##sys#setslot (car bp) 0 (cdr bp)))
518              broken-procedures)
519    (set! broken-procedures '())
520    (##sys#void)))
521
522;;; Parse options from string:
523
524(define (parse-option-string str)
525  (let ([ins (open-input-string str)])
526    (map (lambda (o)
527           (if (string? o)
528               o
529               (let ([os (open-output-string)])
530                 (write o os)
531                 (get-output-string os) ) ) )
532         (handle-exceptions ex (##sys#error "invalid option syntax" str)
533           (do ([x (read ins) (read ins)]
534                [xs '() (cons x xs)] )
535               ((eof-object? x) (reverse xs)) ) ) ) ) )
536
537
538;;; Print status information:
539
540(define report
541  (let ((printf printf)
542        (chop chop)
543        (sort sort)
544        (with-output-to-port with-output-to-port)
545        (current-output-port current-output-port) )
546    (lambda port
547      (with-output-to-port (if (pair? port) (car port) (current-output-port))
548        (lambda ()
549          (gc)
550          (let ([sinfo (##sys#symbol-table-info)]
551                [minfo (memory-statistics)] )
552            (define (shorten n) (/ (truncate (* n 100)) 100))
553            (printf "Features:")
554            (for-each
555             (lambda (lst) 
556               (display "\n  ")
557               (for-each
558                (lambda (f)
559                  (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
560                lst) )
561             (chop (sort (map keyword->string ##sys#features) string<?) 5))
562            (printf "~%~
563                   Machine type:    \t~A ~A~%~
564                   Software type:   \t~A~%~
565                   Software version:\t~A~%~
566                   Build platform:  \t~A~%~
567                   Include path:    \t~A~%~
568                   Symbol-table load:\t~S~%  ~
569                     Avg bucket length:\t~S~%  ~
570                     Total symbol count:\t~S~%~
571                   Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~ 
572                     nursery size is ~S bytes, stack grows ~A~%"
573                    (machine-type)
574                    (if (##sys#fudge 3) "(64-bit)" "")
575                    (software-type)
576                    (software-version)
577                    (build-platform)
578                    ##sys#include-pathnames
579                    (shorten (vector-ref sinfo 0))
580                    (shorten (vector-ref sinfo 1))
581                    (vector-ref sinfo 2)
582                    (vector-ref minfo 0)
583                    (if (##sys#fudge 17) " (fixed)" "")
584                    (vector-ref minfo 1)
585                    (vector-ref minfo 2)
586                    (if (= 1 (##sys#fudge 18)) "downward" "upward") )
587            (##sys#write-char-0 #\newline ##sys#standard-output)
588            (when (##sys#fudge 14) (display "interrupts are enabled\n"))
589            (when (##sys#fudge 15) (display "symbol gc is enabled\n")) 
590            (##core#undefined) ) ) ) ) ) )
591
592
593;;; Describe & dump:
594
595(define bytevector-data
596  '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)
597    (s8vector "vector of signed bytes" s8vector-length s8vector-ref)
598    (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)
599    (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)
600    (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)
601    (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)
602    (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)
603    (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )
604
605(define-constant max-describe-lines 40)
606
607(define describer-table (make-vector 37 '()))
608
609(define describe
610  (let ([sprintf sprintf]
611        [printf printf] 
612        [fprintf fprintf]
613        [length length]
614        [list-ref list-ref]
615        [string-ref string-ref])
616    (lambda (x #!optional (out ##sys#standard-output))
617      (define (descseq name plen pref start)
618        (let ((len (fx- (plen x) start)))
619          (when name (fprintf out "~A of length ~S~%" name len))
620          (let loop1 ((i 0))
621            (cond ((fx>= i len))
622                  ((fx>= i max-describe-lines)
623                   (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )
624                  (else
625                   (let ((v (pref x (fx+ start i))))
626                     (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))
627                       (cond ((fx>= j len)
628                              (fprintf out " ~S: ~S" i v)
629                              (if (fx> n 1)
630                                  (fprintf out "\t(followed by ~A identical instance~a)~% ...~%" 
631                                           (fx- n 1)
632                                           (if (eq? n 2) "" "s"))
633                                  (newline out) )
634                              (loop1 (fx+ i n)) )
635                             ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))
636                             (else (loop2 n len)) ) ) ) ) ) ) ) )
637      (when (##sys#permanent? x)
638        (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )
639      (cond [(char? x)
640             (let ([code (char->integer x)])
641               (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) ]
642            [(eq? x #t) (fprintf out "boolean true~%")]
643            [(eq? x #f) (fprintf out "boolean false~%")]
644            [(null? x) (fprintf out "empty list~%")]
645            [(eof-object? x) (fprintf out "end-of-file object~%")]
646            [(eq? (##sys#void) x) (fprintf out "unspecified object~%")]
647            [(fixnum? x)
648             (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
649             (let ([code (integer->char x)])
650               (when (fx< x #x10000) (fprintf out ", character ~S" code)) )
651             (##sys#write-char-0 #\newline ##sys#standard-output) ]
652            [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
653             (fprintf out "unbound value~%") ]
654            [(##sys#number? x) (fprintf out "number ~S~%" x)]
655            [(string? x) (descseq "string" ##sys#size string-ref 0)]
656            [(vector? x) (descseq "vector" ##sys#size ##sys#slot 0)]
657            [(symbol? x)
658             (unless (##sys#symbol-has-toplevel-binding? x) (display "unbound " out))
659             (when (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0)))
660               (display "keyword " out) )
661             (fprintf out "~asymbol with name ~S~%"
662                      (if (##sys#interned-symbol? x) "" "uninterned ")
663                      (##sys#symbol->string x))
664             (let ((plist (##sys#slot x 2)))
665               (unless (null? plist)
666                 (display "  \nproperties:\n\n" out)
667                 (do ((plist plist (cddr plist)))
668                     ((null? plist))
669                   (fprintf out "  ~s\t" (car plist))
670                   (##sys#with-print-length-limit
671                    1000
672                    (lambda ()
673                      (write (cadr plist) out) ) )
674                   (newline out) ) ) ) ]
675            [(list? x) (descseq "list" length list-ref 0)]
676            [(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
677            [(procedure? x)
678             (let ([len (##sys#size x)])
679               (if (and (> len 3)
680                        (memq #:tinyclos ##sys#features)
681                        (eq? ##tinyclos#entity-tag (##sys#slot x (fx- len 1))) ) ;XXX handle this in tinyclos egg (difficult)
682                   (describe-object x out)
683                   (descseq 
684                    (sprintf "procedure with code pointer ~X" (##sys#peek-unsigned-integer x 0))
685                    ##sys#size ##sys#slot 1) ) ) ]
686            [(port? x)
687             (fprintf out
688                      "~A port of type ~A with name ~S and file pointer ~X~%"
689                      (if (##sys#slot x 1) "input" "output")
690                      (##sys#slot x 7)
691                      (##sys#slot x 3)
692                      (##sys#peek-unsigned-integer x 0) ) ]
693            [(and (memq #:tinyclos ##sys#features) (instance? x)) ; XXX put into tinyclos egg
694             (describe-object x out) ]
695            [(##sys#locative? x)
696             (fprintf out "locative~%  pointer ~X~%  index ~A~%  type ~A~%"
697                      (##sys#peek-unsigned-integer x 0)
698                      (##sys#slot x 1)
699                      (case (##sys#slot x 2) 
700                        [(0) "slot"]
701                        [(1) "char"]
702                        [(2) "u8vector"]
703                        [(3) "s8vector"]
704                        [(4) "u16vector"]
705                        [(5) "s16vector"]
706                        [(6) "u32vector"]
707                        [(7) "s32vector"]
708                        [(8) "f32vector"]
709                        [(9) "f64vector"] ) ) ]
710            [(##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0))]
711            [(##sys#bytevector? x)
712             (let ([len (##sys#size x)])
713               (fprintf out "blob of size ~S:~%" len)
714               (hexdump x len ##sys#byte out) ) ]
715            [(##core#inline "C_lambdainfop" x)
716             (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) ]
717            [(##sys#structure? x 'hash-table)
718             (let ((n (##sys#slot x 2)))
719               (fprintf out "hash-table with ~S element~a~%  comparison procedure: ~A~%"
720                        n (if (fx= n 1) "" "s")  (##sys#slot x 3)) )
721             (fprintf out "  hash function: ~a~%" (##sys#slot x 4))
722             (hash-table-walk           ; blindly assumes it is bound
723              x
724              (lambda (k v) (fprintf out " ~S\t-> ~S~%" k v)) ) ]
725            [(##sys#structure? x 'condition)
726             (fprintf out "condition: ~s~%" (##sys#slot x 1))
727             (for-each
728              (lambda (k)
729                (fprintf out " ~s~%" k)
730                (let loop ((props (##sys#slot x 2)))
731                  (unless (null? props)
732                    (when (eq? k (caar props))
733                      (fprintf out "\t~s: ~s~%" (cdar props) (cadr props)) )
734                    (loop (cddr props)) ) ) )
735              (##sys#slot x 1) ) ]
736            [(and (##sys#structure? x 'meroon-instance) (provided? 'meroon)) ; XXX put this into meroon egg (really!)
737             (unveil x out) ]
738            [(##sys#generic-structure? x)
739             (let ([st (##sys#slot x 0)])
740               (cond ((##sys#hash-table-ref describer-table st) => (cut <> x out))
741                     ((assq st bytevector-data) =>
742                      (lambda (data)
743                        (apply descseq (append (map eval (cdr data)) (list 0)))) )
744                     (else
745                      (fprintf out "structure of type `~S':~%" (##sys#slot x 0))
746                      (descseq #f ##sys#size ##sys#slot 1) ) ) ) ]
747            [else (fprintf out "unknown object~%")] )
748      (##sys#void) ) ) )
749
750(define (set-describer! tag proc)
751  (##sys#check-symbol tag 'symbol 'set-describer!)
752  (##sys#hash-table-set! describer-table tag proc) )
753
754
755;;; Display hexdump:
756
757(define dump
758  (lambda (x . len-out)
759    (let-optionals len-out
760        ([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) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
766            [(and (not (##sys#immediate? x)) (##sys#pointer? x))
767             (hexdump x 32 ##sys#peek-byte out) ]
768            [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
769             (let ([bv (##sys#slot x 1)])
770               (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
771            [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )
772
773(define hexdump
774  (let ([display display]
775        [string-append string-append]
776        [make-string make-string]
777        [write-char write-char] )
778    (lambda (bv len ref out)
779
780      (define (justify n m base lead)
781        (let* ([s (number->string n base)]
782               [len (##sys#size s)] )
783          (if (fx< len m)
784              (string-append (make-string (fx- m len) lead) s)
785              s) ) )
786
787      (do ([a 0 (fx+ a 16)])
788          ((fx>= a len))
789        (display (justify a 4 10 #\space) out)
790        (write-char #\: out)
791        (do ([j 0 (fx+ j 1)]
792             [a a (fx+ a 1)] )
793            ((or (fx>= j 16) (fx>= a len))
794             (and-let* ([(fx>= a len)]
795                        [o (fxmod len 16)]
796                        [(not (fx= o 0))] )
797               (do ([k (fx- 16 o) (fx- k 1)])
798                   ((fx= k 0))
799                 (display "   " out) ) ) )
800          (write-char #\space out)
801          (display (justify (ref bv a) 2 16 #\0) out) )
802        (write-char #\space out)
803        (do ([j 0 (fx+ j 1)]
804             [a a (fx+ a 1)] )
805            ((or (fx>= j 16) (fx>= a len)))
806          (let ([c (ref bv a)])
807            (if (and (fx>= c 32) (fx< c 128))
808                (write-char (integer->char c) out)
809                (write-char #\. out) ) ) ) 
810        (##sys#write-char-0 #\newline out) ) ) ) )
811
812
813;;; Start interpreting:
814
815(define (deldups lis . maybe-=)
816  (let ((elt= (optional maybe-= equal?)))
817    (let recur ((lis lis))
818      (if (null? lis) lis
819          (let* ((x (car lis))
820                 (tail (cdr lis))
821                 (new-tail (recur (del x tail elt=))))
822            (if (eq? tail new-tail) lis (cons x new-tail)))))))
823
824(define (member* keys set)
825  (let loop ((set set))
826    (and (pair? set)
827         (let find ((ks keys))
828           (cond ((null? ks) (loop (cdr set)))
829                 ((equal? (car ks) (car set)) set)
830                 (else (find (cdr ks))) ) ) ) ) )
831
832(define-constant short-options 
833  '(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P) )
834
835(define-constant long-options
836  '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-eval"
837    "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"
838    "-r5rs-syntax"
839    "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init" 
840    "-include-path" "-release" "-print" "-pretty-print" "--") )
841
842(define (canonicalize-args args)
843  (let loop ((args args))
844    (if (null? args)
845        '()
846        (let ((x (car args)))
847          (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)
848                ((and (fx> (##sys#size x) 2)
849                       (char=? #\- (##core#inline "C_subchar" x 0))
850                       (not (member x long-options)) )
851                 (if (char=? #\: (##core#inline "C_subchar" x 1))
852                     (loop (cdr args))
853                     (let ((cs (string->list (substring x 1))))
854                       (if (findall cs short-options)
855                           (append (map (cut string #\- <>) cs) (loop (cdr args)))
856                           (##sys#error "invalid option" x) ) ) ) )
857                (else (cons x (loop (cdr args)))))))))
858
859(define (findall chars clist)
860  (let loop ((chars chars))
861    (or (null? chars)
862        (and (memq (car chars) clist)
863             (loop (cdr chars))))))
864
865(define-constant simple-options
866  '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings" "-i" "-case-insensitive"
867    "-no-parentheses-synonyms" "-no-symbol-escape" "-r5rs-syntax"
868    ; Not "simple" but processed early
869    "-ss" "-sx" "-s" "-script") )
870
871(define-constant complex-options
872  '("-D" "-feature" "-I" "-include-path" "-k" "-keyword-style") )
873
874(define (run)
875  (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]
876         [args (canonicalize-args (command-line-arguments))]
877         ; Check for these before 'args' is updated by any 'extraopts'
878         [kwstyle (member* '("-k" "-keyword-style") args)]
879         [script (member* '("-ss" "-sx" "-s" "-script") args)])
880    (cond [script
881           (when (or (not (pair? (cdr script)))
882                     (zero? (string-length (cadr script)))
883                     (char=? #\- (string-ref (cadr script) 0)) )
884             (##sys#error "missing or invalid script argument"))
885           (program-name (cadr script))
886           (command-line-arguments (cddr script))
887           (register-feature! 'script)
888           (set-cdr! (cdr script) '()) 
889           (when ##sys#windows-platform
890             (and-let* ((sname (lookup-script-file (cadr script))))
891               (set-car! (cdr script) sname) ) ) ]
892          [else
893           (set! args (append (canonicalize-args extraopts) args))
894           (and-let* ([p (member "--" args)])
895             (set-cdr! p '()) ) ] )
896    (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]
897           [batch (or script (member* '("-b" "-batch") args) eval?)]
898           [quietflag (member* '("-q" "-quiet") args)]
899           [quiet (or script quietflag eval?)]
900           [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))] )     
901      (define (collect-options opt)
902        (let loop ([opts args])
903          (cond [(member opt opts) 
904                 => (lambda (p)
905                      (if (null? (cdr p))
906                          (##sys#error "missing argument to command-line option" opt)
907                          (cons (cadr p) (loop (cddr p)))) ) ]
908                [else '()] ) ) )
909      (define (loadinit)
910        (let ([fn (##sys#string-append "./" init-file)])
911          (if (file-exists? fn)
912              (load fn)
913              (let* ([prefix (chop-separator (or (get-environment-variable "HOME") "."))]
914                     [fn (string-append prefix "/" init-file)] )
915                (when (file-exists? fn) 
916                  (load fn) ) ) ) ) )
917      (define (evalstring str #!optional (rec (lambda _ (void))))
918        (let ((in (open-input-string str)))
919          (do ([x (read in) (read in)])
920              ((eof-object? x))
921            (rec (receive (eval x))) ) ) )
922      (when quietflag (set! ##sys#eval-debug-level 0))
923      (when (member* '("-h" "-help" "--help") args)
924        (print-usage)
925        (exit 0) )
926      (when (member* '("-v" "-version") args)
927        (print-banner)
928        (exit 0) )
929      (when (member "-release" args)
930        (print (chicken-version))
931        (exit 0) )
932      (when (member* '("-w" "-no-warnings") args)
933        (unless quiet (display "Warnings are disabled\n"))
934        (set! ##sys#warnings-enabled #f) )
935      (unless quiet
936        (load-verbose #t)
937        (print-banner) )
938      (when (member* '("-i" "-case-insensitive") args)
939        (unless quiet (display "Identifiers and symbols are case insensitive\n"))
940        (register-feature! 'case-insensitive)
941        (case-sensitive #f) )
942      (for-each register-feature! (collect-options "-feature"))
943      (for-each register-feature! (collect-options "-D"))
944      (set! ##sys#include-pathnames 
945        (deldups
946         (append (map chop-separator (collect-options "-include-path"))
947                 (map chop-separator (collect-options "-I"))
948                 ##sys#include-pathnames
949                 ipath)
950         string=?) )
951      (when kwstyle
952        (cond [(not (pair? (cdr kwstyle)))
953               (##sys#error "missing argument to `-keyword-style' option") ]
954              [(string=? "prefix" (cadr kwstyle))
955               (keyword-style #:prefix) ]
956              [(string=? "none" (cadr kwstyle))
957               (keyword-style #:none) ]
958              [(string=? "suffix" (cadr kwstyle))
959               (keyword-style #:suffix) ] ) )
960      (when (member* '("-no-parentheses-synonyms") args)
961        (unless quiet (display "Disabled support for parentheses synonyms\n"))
962        (parentheses-synonyms #f) )
963      (when (member* '("-no-symbol-escape") args)
964        (unless quiet (display "Disabled support for escaped symbols\n"))
965        (symbol-escape #f) )
966      (when (member* '("-r5rs-syntax") args)
967        (unless quiet (display "Disabled the Chicken extensions to R5RS syntax\n"))
968        (case-sensitive #f)
969        (keyword-style #:none)
970        (parentheses-synonyms #f)
971        (symbol-escape #f) )
972      (unless (or (member* '("-n" "-no-init") args) script) (loadinit))
973      (do ([args args (cdr args)])
974          ((null? args)
975           (unless batch 
976             (repl)
977             (##sys#write-char-0 #\newline ##sys#standard-output) ) )
978        (let* ([arg (car args)]
979               #;[len (string-length arg)] )
980          (cond ((member arg simple-options) )
981                ((member arg complex-options)
982                 (set! args (cdr args)) )
983                ((or (string=? "-R" arg) (string=? "-require-extension" arg))
984                 (eval `(##core#require-extension (,(string->symbol (cadr args))) #t))
985                 (set! args (cdr args)) )
986                ((or (string=? "-e" arg) (string=? "-eval" arg))
987                 (evalstring (cadr args))
988                 (set! args (cdr args)) )
989                ((or (string=? "-p" arg) (string=? "-print" arg))
990                 (evalstring (cadr args) (cut for-each print <...>))
991                 (set! args (cdr args)) )
992                ((or (string=? "-P" arg) (string=? "-pretty-print" arg))
993                 (evalstring (cadr args) (cut for-each pretty-print <...>) )
994                 (set! args (cdr args)) )
995                (else
996                 (let ((scr (and script (car script))))
997                   (##sys#load 
998                    arg 
999                    (and (equal? "-sx" scr)
1000                         (lambda (x)
1001                           (pretty-print x ##sys#standard-error)
1002                           (newline ##sys#standard-error)
1003                           (eval x)))
1004                    #f)
1005                   (when (equal? "-ss" scr)
1006                     (call-with-values (cut main (command-line-arguments))
1007                       (lambda results
1008                         (exit
1009                          (if (and (pair? results) (fixnum? (car results)))
1010                              (car results)
1011                              0) ) ) ) ) ) ) ) ) ) ) ) )
1012
1013(run)
Note: See TracBrowser for help on using the repository browser.