source: project/chicken/trunk/csi.scm @ 13672

Last change on this file since 13672 was 13672, checked in by Kon Lovett, 12 years ago

Added 'parenthesis-synonyms' concept. Updated the unsafe inlines w/ more routines & better names.

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