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

Last change on this file since 15921 was 15921, checked in by Ivan Raikov, 10 years ago

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