conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added delete-file.

This commit is contained in:
Abdulaziz Ghuloum 2007-08-26 20:04:00 -04:00
parent 1135803c81
commit 7bb5eab307
4 changed files with 106 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

26
src/ikarus.io-ports.ss
View File

@ -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)))))

2
src/makefile.ss
View File

@ -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]

115
src/r6rs-todo.ss
View File

@ -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 (<status>|<libname>)*\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)))]
))