diff --git a/src/ikarus.boot b/src/ikarus.boot index 88088d9..1437270 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.command-line.ss b/src/ikarus.command-line.ss index 174de87..553b4ab 100644 --- a/src/ikarus.command-line.ss +++ b/src/ikarus.command-line.ss @@ -1,10 +1,11 @@ (library (ikarus command-line) - (export command-line-arguments) + (export command-line-arguments command-line) (import (ikarus system $arg-list) - (except (ikarus) command-line-arguments)) + (except (ikarus) command-line command-line-arguments)) + (define (command-line) (command-line-arguments)) (define command-line-arguments (make-parameter ($arg-list) (lambda (x) diff --git a/src/ikarus.main.ss b/src/ikarus.main.ss index 8ef5069..309ac2e 100644 --- a/src/ikarus.main.ss +++ b/src/ikarus.main.ss @@ -49,7 +49,7 @@ (load-r6rs-top-level script) ;(load script) (exit 0)] - [script ; no greeting, no cafe + [(eq? script-type 'script) ; no greeting, no cafe (command-line-arguments (cons script args)) (for-each load files) (load script) diff --git a/src/makefile.ss b/src/makefile.ss index a14ea82..b800197 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -550,6 +550,7 @@ [environment? i] [time-it i] [command-line-arguments i] + [command-line i r] [record? i] [make-record-type i] [record-type-descriptor i] diff --git a/src/r6rs-todo.ss b/src/r6rs-todo.ss index 01cd47d..a8428e2 100755 --- a/src/r6rs-todo.ss +++ b/src/r6rs-todo.ss @@ -524,8 +524,8 @@ [string-set! C ms] [string-fill! S ms] - [command-line S pr] - [exit S pr] + [command-line C pr] + [exit C pr] [delay D r5] [exact->inexact D r5] @@ -804,28 +804,60 @@ (define (count-status x) (length (filter* (list x)))) +(define (join s ls) + (cond + [(null? ls) ""] + [(null? (cdr ls)) (format "~a" (car ls))] + [else + (format "~a~a~a" (car ls) s (join s (cdr ls)))])) + +(define (status-str x) + (cond + [(assq x identifier-names) + => + (lambda (x) + (let ([st (cadr x)] [libs (cddr x)]) + (format "(~a ~a)" st (join "," libs))))] + [else (error)])) + (define (print-ids ls) (define (split ls n) (cond [(null? ls) (values '() '())] - [(> (string-length (symbol->string (car ls))) n) + [(> (string-length (car ls)) n) (values '() ls)] [else (let-values ([(fst rest) (split (cdr ls) (- n - (string-length (symbol->string (car ls))) - 1))]) + (string-length (car ls))))]) (values (cons (car ls) fst) rest))])) - (unless (null? ls) - (let-values ([(ls rest) - (split ls 80)]) - (for-each - (lambda (x) - (printf "~s " x)) - ls) - (newline) - (print-ids rest)))) + (define (print-ids ls) + (unless (null? ls) + (let-values ([(ls rest) + (split ls 80)]) + (for-each display ls) + (newline) + (print-ids rest)))) + (print-ids + (map (lambda (x) (format "~s ~a " x (status-str x))) ls))) + + +(define (split p ls) + (cond + [(null? ls) (values '() '())] + [else + (let-values ([(ls1 ls2) + (split p (cdr ls))]) + (if (p (car ls)) + (values (cons (car ls) ls1) ls2) + (values ls1 (cons (car ls) ls2))))])) + +(define (null-intersection? ls1 ls2) + (cond + [(null? ls1) #t] + [(memq (car ls1) ls2) #f] + [else (null-intersection? (cdr ls1) ls2)])) (no-dups (map car identifier-names)) (no-dups (map car library-names)) @@ -833,7 +865,6 @@ (for-each assert-id identifier-names) - (let ([args (cdr (command-line-arguments))] [exe (car (command-line-arguments))]) (cond @@ -851,8 +882,27 @@ (count-status (car x)))) status-names)] [else - (let ([ls (filter* (map string->symbol args))]) - (printf "~s identifiers\n" (length ls)) - (print-ids (map car ls)))] + (let-values ([(s* l*) + (split + (lambda (x) + (cond + [(assq x status-names) #t] + [(assq x library-names) #f] + [else (error #f "invalid argument ~a" x)])) + (map string->symbol args))]) + (let ([ls (filter + (lambda (x) + (let ([s (cadr x)] + [libs (cddr x)]) + (cond + [(null? l*) (memq s s*)] + [(null? s*) + (not (null-intersection? l* libs))] + [else + (and (memq s s*) + (not (null-intersection? l* libs)))]))) + identifier-names)]) + (printf "~s identifiers\n" (length ls)) + (print-ids (map car ls))))] ))