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

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