diff --git a/src/ikarus.boot b/src/ikarus.boot index a7029e3..88088d9 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.io-ports.ss b/src/ikarus.io-ports.ss index 751b6c2..4db64b7 100644 --- a/src/ikarus.io-ports.ss +++ b/src/ikarus.io-ports.ss @@ -1,6 +1,6 @@ (library (ikarus io-ports) - (export make-input-port make-output-port ;make-input/output-port + (export make-input-port make-output-port port-handler port-input-buffer port-output-buffer port-input-index set-port-input-index! @@ -14,7 +14,6 @@ (ikarus system $fx) (except (ikarus) make-input-port make-output-port - ;make-input/output-port port-handler port-input-buffer port-output-buffer port-input-index set-port-input-index! @@ -27,7 +26,6 @@ ;;; * Constructors: ;;; (make-input-port handler input-buffer) ;;; (make-output-port handler output-buffer) - ;;; (make-input/output-port handler input-buffer output-buffer) ;;; ;;; * Predicates: ;;; (port? x) @@ -36,22 +34,13 @@ ;;; ;;; * Accessors: ;;; (port-handler port) - ;;; (port-input-buffer port) - ;;; (port-input-index port) - ;;; (port-input-size port) - ;;; (port-output-buffer port) - ;;; (port-output-index port) - ;;; (port-output-size port) + ;;; (port-buffer port) + ;;; (port-index port) + ;;; (port-size port) ;;; ;;; * Mutators: - ;;; (set-port-handler! port proc) - ;;; (set-port-input-buffer! port string) - ;;; (set-port-input-index! port fixnum) - ;;; (set-port-input-size! port fixnum) - ;;; (set-port-output-buffer! port string) - ;;; (set-port-output-index! port fixnum) - ;;; (set-port-output-size! port fixnum) - ;;; + ;;; (set-port-index! port fixnum) + ;;; (set-port-size! port fixnum) ;;; (define $make-input-port (lambda (handler buffer) @@ -170,3 +159,6 @@ (error 'set-port-output-size! "size ~s is negative" i)) (error 'set-port-output-size! "~s is not a valid size" i)) (error 'set-port-output-size! "~s is not an output-port" p))))) + + + diff --git a/src/makefile.ss b/src/makefile.ss index 26619dd..a14ea82 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -467,7 +467,6 @@ [make-guardian i] [make-input-port i] [make-output-port i] - [make-input/output-port i] [port-output-index i] [port-output-size i] [port-output-buffer i] @@ -507,6 +506,7 @@ [flush-output-port i] [reset-input-port! i] [file-exists? i] + [delete-file i] [display i r] [write i r] [write-char i r] diff --git a/src/r6rs-todo.ss b/src/r6rs-todo.ss index 49193fb..01cd47d 100755 --- a/src/r6rs-todo.ss +++ b/src/r6rs-todo.ss @@ -33,21 +33,13 @@ )) (define status-names - '([D deferred] + '( [P progress] [S scheduled] [C completed] + [D deferred] [U unknown])) - - - - - - - - - (define identifier-names '( @@ -426,7 +418,6 @@ [condition-message D co] [condition-predicate D co] [condition-who D co] - [condition? D co] [define-condition-type D co] [&error D co] [error? D co] @@ -496,10 +487,7 @@ [raise D ex] [raise-continuable D ex] [with-exception-handler D ex] - [with-exception-handler D ex] [guard D ex] - [raise D ex] - [raise-continuable D ex] [binary-port? D ip] [buffer-mode D ip] @@ -509,7 +497,6 @@ [call-with-port D ip] [call-with-string-output-port D ip] - [assoc C ls] [assp S ls] [assq C ls] @@ -678,8 +665,6 @@ [hashtable-copy S ht] [hashtable-delete! S ht] [hashtable-entries S ht] - [hashtable-equivalence-function S ht] - [hashtable-hash-function S ht] [hashtable-keys S ht] [hashtable-mutable? S ht] [hashtable-ref S ht] @@ -689,7 +674,9 @@ [hashtable? S ht] [make-eq-hashtable S ht] [make-eqv-hashtable S ht] - [make-hashtable S ht] + [hashtable-hash-function D ht] + [make-hashtable D ht] + [hashtable-equivalence-function D ht] [equal-hash D ht] [string-hash D ht] [string-ci-hash D ht] @@ -700,7 +687,7 @@ [vector-sort! S sr] [file-exists? C fi] - [delete-file S fi] + [delete-file C fi] [define-record-type D rs] [fields D rs] @@ -779,3 +766,93 @@ [string-upcase S uc] )) + +(define (no-dups ls) + (unless (null? ls) + (when (memq (car ls) (cdr ls)) + (error #f "duplicate ~s" (car ls))) + (no-dups (cdr ls)))) + +(define (assert-id x) + (unless (and (>= (length x) 3) + (let ([name (car x)] + [status (cadr x)] + [libs (cddr x)]) + (no-dups libs) + (and (assq status status-names) + (andmap (lambda (x) + (assq x library-names)) + libs)))) + (error #f "invalid id ~s" x))) + +(define (filter p? ls) + (cond + [(null? ls) '()] + [(p? (car ls)) + (cons (car ls) (filter p? (cdr ls)))] + [else (filter p? (cdr ls))])) + +(define (filter* ls) + (filter + (lambda (x) + (not (null? (filter + (lambda (x) + (memq x ls)) + (cdr x))))) + identifier-names)) + +(define (count-status x) + (length (filter* (list x)))) + +(define (print-ids ls) + (define (split ls n) + (cond + [(null? ls) (values '() '())] + [(> (string-length (symbol->string (car ls))) n) + (values '() ls)] + [else + (let-values ([(fst rest) + (split (cdr ls) + (- n + (string-length (symbol->string (car ls))) + 1))]) + (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)))) + +(no-dups (map car identifier-names)) +(no-dups (map car library-names)) +(no-dups (map car status-names)) +(for-each assert-id identifier-names) + + + +(let ([args (cdr (command-line-arguments))] + [exe (car (command-line-arguments))]) + (cond + [(null? args) + (printf "usage: ~a (|)*\n\n" exe) + (printf "Library Names:\n") + (for-each + (lambda (x) + (printf " ~a ~a\n" (car x) (cadr x))) + library-names) + (printf "Status Codes:\n") + (for-each + (lambda (x) + (printf " ~a ~a (~s ids)\n" (car x) (cadr x) + (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)))] + )) +