scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Hacked the system to use the new LET-OPT optional argument machinery, 

LET-OPTIONAL, LET-OPTIONAL*, and :OPTIONAL. The new macros are
faster and easier to read than the old PARSE-OPTIONALS and OPTIONAL-ARG
procedures.
This commit is contained in:
shivers 1996-04-19 18:39:14 +00:00
parent 6b42e9d7aa
commit ea45fca8ef
16 changed files with 115 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scsh/filesys.scm
View File

@ -82,7 +82,7 @@
(create-file-thing new-fname (create-file-thing new-fname
(lambda (new-fname) (lambda (new-fname)
(create-hard-link/errno old-fname new-fname)) (create-hard-link/errno old-fname new-fname))
(optional-arg maybe-override? #f) (:optional maybe-override? #f)
"create-hard-link" "create-hard-link"
create-hard-link)) create-hard-link))
@ -90,7 +90,7 @@
(create-file-thing new-fname (create-file-thing new-fname
(lambda (symlink) (lambda (symlink)
(create-symlink/errno old-fname symlink)) (create-symlink/errno old-fname symlink))
(optional-arg maybe-override? #f) (:optional maybe-override? #f)
"create-symlink" "create-symlink"
create-symlink)) create-symlink))
@ -103,7 +103,7 @@
;;; us not to. That's life in the food chain. ;;; us not to. That's life in the food chain.
(define (rename-file old-fname new-fname . maybe-override?) (define (rename-file old-fname new-fname . maybe-override?)
(let ((override? (optional-arg maybe-override? #f))) (let ((override? (:optional maybe-override? #f)))
(if (or (and override? (not (eq? override? 'query))) (if (or (and override? (not (eq? override? 'query)))
(file-not-exists? new-fname) (file-not-exists? new-fname)
(and override? (and override?

2
scsh/flock.scm
View File

@ -67,7 +67,7 @@
(define set-lock-region:pid set-%lock-region:pid) (define set-lock-region:pid set-%lock-region:pid)
(define (make-lock-region exclusive? start len . maybe-whence) (define (make-lock-region exclusive? start len . maybe-whence)
(let ((whence (optional-arg maybe-whence seek/set))) (let ((whence (:optional maybe-whence seek/set)))
(make-%lock-region exclusive? start len whence 0))) (make-%lock-region exclusive? start len whence 0)))

4
scsh/fname.scm
View File

@ -98,7 +98,7 @@
(define (path-list->file-name pathlist . maybe-dir) (define (path-list->file-name pathlist . maybe-dir)
(let ((root (ensure-file-name-is-nondirectory (optional-arg maybe-dir "."))) (let ((root (ensure-file-name-is-nondirectory (:optional maybe-dir ".")))
;; Insert slashes *between* elts of PATHLIST. ;; Insert slashes *between* elts of PATHLIST.
(w/slashes (if (pair? pathlist) (w/slashes (if (pair? pathlist)
(let insert-slashes ((pathlist pathlist)) (let insert-slashes ((pathlist pathlist))
@ -162,7 +162,7 @@
fname))) fname)))
(define (resolve-file-name fname . maybe-root) (define (resolve-file-name fname . maybe-root)
(let* ((root (ensure-file-name-is-nondirectory (optional-arg maybe-root "."))) (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
(fname (ensure-file-name-is-nondirectory fname)) (fname (ensure-file-name-is-nondirectory fname))
(len (string-length fname))) (len (string-length fname)))
(if (zero? len) "/" (if (zero? len) "/"

2
scsh/jcontrol2.scm
View File

@ -141,7 +141,7 @@
;;; Except no MASK for now. ;;; Except no MASK for now.
(define (%set-interrupt-handler interrupt handler . args) (define (%set-interrupt-handler interrupt handler . args)
(receive (flags) (parse-optionals args 0) (let-optionals args ((flags 0))
(receive (err handler flags) (receive (err handler flags)
(%%set-interrupt-handler interrupt handler flags) (%%set-interrupt-handler interrupt handler flags)
(if err (if err

114
scsh/network.scm
View File

@ -143,8 +143,7 @@
;;; socket syscall ;;; socket syscall
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (create-socket pf type . maybe-protocol) (define (create-socket pf type . maybe-protocol)
(receive (protocol) (let ((protocol (:optional maybe-protocol 0)))
(parse-optionals maybe-protocol 0)
(if (not (and (integer? pf) (if (not (and (integer? pf)
(integer? type) (integer? type)
(integer? protocol))) (integer? protocol)))
@ -366,8 +365,7 @@
;;; recv syscall ;;; recv syscall
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (receive-message socket len . maybe-flags) (define (receive-message socket len . maybe-flags)
(receive (flags) (let ((flags (:optional maybe-flags 0)))
(parse-optionals maybe-flags 0)
(cond ((not (socket? socket)) (cond ((not (socket? socket))
(error "receive-message: socket expected ~s" socket)) (error "receive-message: socket expected ~s" socket))
((or (not (integer? flags)) ((or (not (integer? flags))
@ -383,23 +381,22 @@
(else (substring s 0 nread))) (else (substring s 0 nread)))
from))))))) from)))))))
(define (receive-message! socket s . maybe-args) (define (receive-message! socket s . args)
(if (not (string? s)) (if (not (string? s))
(error "receive-message!: string expected ~s" s) (error "receive-message!: string expected ~s" s)
(receive (start end flags) (let-optionals args ((start 0) (end (string-length s)) (flags 0))
(parse-optionals maybe-args 0 (string-length s) 0) (cond ((not (socket? socket))
(cond ((not (socket? socket)) (error "receive-message!: socket expected ~s" socket))
(error "receive-message!: socket expected ~s" socket)) ((not (or (integer? flags)
((not (or (integer? flags) (integer? start)
(integer? start) (integer? end)))
(integer? end))) (error "receive-message!: integer expected ~s ~s ~s"
(error "receive-message!: integer expected ~s ~s ~s" flags start end))
flags start end)) (else
(else (generic-receive-message! (socket->fdes socket) flags
(generic-receive-message! (socket->fdes socket) flags s start end
s start end recv-substring!/errno
recv-substring!/errno (socket:family socket)))))))
(socket:family socket)))))))
(define (generic-receive-message! sockfd flags s start end reader from) (define (generic-receive-message! sockfd flags s start end reader from)
(if (bogus-substring-spec? s start end) (if (bogus-substring-spec? s start end)
@ -424,8 +421,7 @@
(else (loop (+ i nread))))))))) (else (loop (+ i nread)))))))))
(define (receive-message/partial socket len . maybe-flags) (define (receive-message/partial socket len . maybe-flags)
(receive (flags) (let ((flags (:optional maybe-flags 0)))
(parse-optionals maybe-flags 0)
(cond ((not (socket? socket)) (cond ((not (socket? socket))
(error "receive-message/partial: socket expected ~s" socket)) (error "receive-message/partial: socket expected ~s" socket))
((or (not (integer? flags)) ((or (not (integer? flags))
@ -441,23 +437,22 @@
(else (substring s 0 nread))) (else (substring s 0 nread)))
addr))))))) addr)))))))
(define (receive-message!/partial socket s . maybe-args) (define (receive-message!/partial socket s . args)
(if (not (string? s)) (if (not (string? s))
(error "receive-message!/partial: string expected ~s" s) (error "receive-message!/partial: string expected ~s" s)
(receive (start end flags) (let-optionals args ((start 0) (end (string-length s)) (flags 0))
(parse-optionals maybe-args 0 (string-length s) 0) (cond ((not (socket? socket))
(cond ((not (socket? socket)) (error "receive-message!/partial: socket expected ~s"
(error "receive-message!/partial: socket expected ~s" socket))
socket)) ((not (integer? flags))
((not (integer? flags)) (error "receive-message!/partial: integer expected ~s"
(error "receive-message!/partial: integer expected ~s" flags))
flags)) (else
(else (generic-receive-message!/partial (socket->fdes socket)
(generic-receive-message!/partial (socket->fdes socket) flags
flags s start end
s start end recv-substring!/errno
recv-substring!/errno (socket:family socket)))))))
(socket:family socket)))))))
(define (generic-receive-message!/partial sockfd flags s start end reader from) (define (generic-receive-message!/partial sockfd flags s start end reader from)
(if (bogus-substring-spec? s start end) (if (bogus-substring-spec? s start end)
@ -493,10 +488,8 @@
;;; send syscall ;;; send syscall
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (send-message socket s . maybe-args) (define (send-message socket s . args)
(receive (start end flags addr) (let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
(parse-optionals maybe-args
0 (string-length s) 0 #f)
(cond ((not (socket? socket)) (cond ((not (socket? socket))
(error "send-message: socket expected ~s" socket)) (error "send-message: socket expected ~s" socket))
((not (integer? flags)) ((not (integer? flags))
@ -527,10 +520,8 @@
s start i end writer))) s start i end writer)))
(loop (+ i nwritten)))))))) (loop (+ i nwritten))))))))
(define (send-message/partial socket s . maybe-args) (define (send-message/partial socket s . args)
(receive (start end flags addr) (let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
(parse-optionals maybe-args
0 (string-length s) 0 #f)
(cond ((not (socket? socket)) (cond ((not (socket? socket))
(error "send-message/partial: socket expected ~s" socket)) (error "send-message/partial: socket expected ~s" socket))
((not (integer? flags)) ((not (integer? flags))
@ -837,13 +828,13 @@
protocol) ; Protocol name protocol) ; Protocol name
(define (service-info . args) (define (service-info . args)
(cond ((string? (car args)) (apply name->service-info args)) (apply (cond ((string? (car args)) name->service-info)
((integer? (car args)) (apply port->service-info args)) ((integer? (car args)) port->service-info)
(else (error "service-info: string or integer expected ~s" args)))) (else (error "service-info: string or integer expected ~s" args)))
args))
(define (port->service-info name . maybe-proto) (define (port->service-info name . maybe-proto)
(receive (proto) (let ((proto (:optional maybe-proto "")))
(parse-optionals maybe-proto "")
(cond ((not (integer? name)) (cond ((not (integer? name))
(error "port->service-info: integer expected ~s" name)) (error "port->service-info: integer expected ~s" name))
((not (string? proto)) ((not (string? proto))
@ -851,11 +842,10 @@
(else (else
(receive (result name aliases port protocol) (receive (result name aliases port protocol)
(%service-port->service-info name proto) (%service-port->service-info name proto)
(make-service-info name (make-service-info name
(vector->list (vector->list (C-string-vec->Scheme aliases #f))
(C-string-vec->Scheme aliases #f)) port
port protocol))))))
protocol))))))
(define-foreign %service-port->service-info (define-foreign %service-port->service-info
(scheme_serv_port2serv_info (integer name) (string proto)) (scheme_serv_port2serv_info (integer name) (string proto))
@ -867,18 +857,10 @@
(define (name->service-info name . maybe-proto) (define (name->service-info name . maybe-proto)
(receive (proto) (receive (result name aliases port protocol)
(parse-optionals maybe-proto "") (%service-name->service-info name (:optional maybe-proto ""))
(if (or (not (string? name)) (make-service-info name (vector->list (C-string-vec->Scheme aliases #f))
(not (string? name))) port protocol)))
(error "name->service-info: string expected ~s" name)
(receive (result name aliases port protocol)
(%service-name->service-info name proto)
(make-service-info name
(vector->list
(C-string-vec->Scheme aliases #f))
port
protocol)))))
(define-foreign %service-name->service-info (define-foreign %service-name->service-info
(scheme_serv_name2serv_info (string name) (string proto)) (scheme_serv_name2serv_info (string name) (string proto))

6
scsh/newports.scm
View File

@ -135,7 +135,7 @@
port)) port))
(define (open-input-file fname . maybe-flags) (define (open-input-file fname . maybe-flags)
(let ((flags (optional-arg maybe-flags 0))) (let ((flags (:optional maybe-flags 0)))
(open-file fname (deposit-bit-field flags open/access-mask open/read)))) (open-file fname (deposit-bit-field flags open/access-mask open/read))))
(define (open-output-file fname . rest) (define (open-output-file fname . rest)
@ -291,7 +291,7 @@
(define-simple-syntax (define-simple-syntax
(define-r4rs-input (name arg ...) stream s48name body ...) (define-r4rs-input (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o) (define (name arg ... . maybe-i/o)
(let ((stream (optional-arg maybe-i/o (current-input-port)))) (let ((stream (:optional maybe-i/o (current-input-port))))
(cond ((input-port? stream) (s48name arg ... stream)) (cond ((input-port? stream) (s48name arg ... stream))
((integer? stream) body ...) ((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream)))))) (else (error "Not a port or file descriptor" stream))))))
@ -313,7 +313,7 @@
(define-simple-syntax (define-simple-syntax
(define-r4rs-output (name arg ...) stream s48name body ...) (define-r4rs-output (name arg ...) stream s48name body ...)
(define (name arg ... . maybe-i/o) (define (name arg ... . maybe-i/o)
(let ((stream (optional-arg maybe-i/o (current-output-port)))) (let ((stream (:optional maybe-i/o (current-output-port))))
(cond ((output-port? stream) (s48name arg ... stream)) (cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...) ((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream)))))) (else (error "Not a port or file descriptor" stream))))))

28
scsh/procobj.scm
View File

@ -35,7 +35,7 @@
#f))) #f)))
(define (pid->proc pid . maybe-probe?) (define (pid->proc pid . maybe-probe?)
(let ((probe? (optional-arg maybe-probe? #f))) (let ((probe? (:optional maybe-probe? #f)))
(or (maybe-pid->proc pid) (or (maybe-pid->proc pid)
(case probe? (case probe?
((#f) (error "Pid has no corresponding process object" pid)) ((#f) (error "Pid has no corresponding process object" pid))
@ -155,7 +155,7 @@
(define (wait pid/proc . maybe-flags) (define (wait pid/proc . maybe-flags)
(if (not *autoreap-policy*) (reap-zombies)) (if (not *autoreap-policy*) (reap-zombies))
(let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait)) (let ((flags (:optional maybe-flags 0))
(proc (->proc pid/proc))) (proc (->proc pid/proc)))
(cond ((proc:%status proc) => ; Already reaped. (cond ((proc:%status proc) => ; Already reaped.
(lambda (status) (lambda (status)
@ -176,17 +176,16 @@
;;; (wait-any [flags]) -> [proc status] ;;; (wait-any [flags]) -> [proc status]
(define (wait-any . maybe-flags) (define (wait-any . maybe-flags)
(let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait-any))) (if (not *autoreap-policy*) (reap-zombies))
(if (not *autoreap-policy*) (reap-zombies)) (cond ((get-reaped-proc!) => ; Check internal table.
(cond ((get-reaped-proc!) => ; Check internal table. (lambda (proc) (values proc (proc:%status proc)))) ; Hit.
(lambda (proc) (values proc (proc:%status proc)))) ; Hit. (else
(else (receive (pid status) (%wait-any (:optional maybe-flags 0)) ; Wait.
(receive (pid status) (%wait-any flags) ; Really wait. (if pid
(if pid (let ((proc (pid->proc pid)))
(let ((proc (pid->proc pid))) (cache-wait-status proc status)
(cache-wait-status proc status) (values proc status))
(values proc status)) (values pid status)))))) ; pid = #f -- Empty poll.
(values pid status))))))) ; pid = #f -- Empty poll.
;;; (wait-process-group [proc-group flags]) ;;; (wait-process-group [proc-group flags])
@ -195,8 +194,7 @@
;;; early autoreaping, since the reaper loses process-group information. ;;; early autoreaping, since the reaper loses process-group information.
(define (wait-process-group . args) (define (wait-process-group . args)
(receive (proc-group flags) (parse-optionals args 0 0) (let-optionals args ((proc-group 0) (flags 0))
(check-arg integer? flags wait-process-group)
(if (not *autoreap-policy*) (reap-zombies)) (if (not *autoreap-policy*) (reap-zombies))
(let ((proc-group (cond ((integer? proc-group) proc-group) (let ((proc-group (cond ((integer? proc-group) proc-group)
((proc? proc-group) (proc:pid proc-group)) ((proc? proc-group) (proc:pid proc-group))

8
scsh/re.scm
View File

@ -16,14 +16,14 @@
(define (match:start match . maybe-index) (define (match:start match . maybe-index)
(vector-ref (regexp-match:start match) (vector-ref (regexp-match:start match)
(optional-arg maybe-index 0))) (:optional maybe-index 0)))
(define (match:end match . maybe-index) (define (match:end match . maybe-index)
(vector-ref (regexp-match:end match) (vector-ref (regexp-match:end match)
(optional-arg maybe-index 0))) (:optional maybe-index 0)))
(define (match:substring match . maybe-index) (define (match:substring match . maybe-index)
(let ((i (optional-arg maybe-index 0))) (let ((i (:optional maybe-index 0)))
(substring (regexp-match:string match) (substring (regexp-match:string match)
(match:start match i) (match:start match i)
(match:end match i)))) (match:end match i))))
@ -38,7 +38,7 @@
(define (make-regexp str) str) (define (make-regexp str) str)
(define (regexp-exec regexp str . maybe-start) (define (regexp-exec regexp str . maybe-start)
(let ((start (optional-arg maybe-start 0)) (let ((start (:optional maybe-start 0))
(start-vec (make-vector 10)) (start-vec (make-vector 10))
(end-vec (make-vector 10))) (end-vec (make-vector 10)))
(and (%regexp-match regexp str start start-vec end-vec) (and (%regexp-match regexp str start start-vec end-vec)

39
scsh/rw.scm
View File

@ -27,10 +27,10 @@
s start start end source))) s start start end source)))
(and (not (zero? nread)) nread)))))) (and (not (zero? nread)) nread))))))
(define (read-string!/partial s . maybe-args) (define (read-string!/partial s . args)
(receive (fd/port start end) (let-optionals args ((fd/port (current-input-port))
(parse-optionals maybe-args (start 0)
(current-input-port) 0 (string-length s)) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-read-string!/partial s start end (generic-read-string!/partial s start end
read-fdes-substring!/errno fd/port)) read-fdes-substring!/errno fd/port))
@ -61,7 +61,7 @@
(define (read-string/partial len . maybe-fd/port) (define (read-string/partial len . maybe-fd/port)
(let* ((s (make-string len)) (let* ((s (make-string len))
(fd/port (optional-arg maybe-fd/port (current-input-port))) (fd/port (:optional maybe-fd/port (current-input-port)))
(nread (read-string!/partial s fd/port 0 len))) (nread (read-string!/partial s fd/port 0 len)))
(cond ((not nread) #f) ; EOF (cond ((not nread) #f) ; EOF
((= nread len) s) ((= nread len) s)
@ -89,10 +89,10 @@
(else (loop (+ i nread)))))))) (else (loop (+ i nread))))))))
(define (read-string! s . maybe-args) (define (read-string! s . args)
(receive (fd/port start end) (let-optionals args ((fd/port (current-input-port))
(parse-optionals maybe-args (start 0)
(current-input-port) 0 (string-length s)) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-read-string! s start end (generic-read-string! s start end
read-fdes-substring!/errno fd/port)) read-fdes-substring!/errno fd/port))
@ -114,7 +114,7 @@
(define (read-string len . maybe-fd/port) (define (read-string len . maybe-fd/port)
(let* ((s (make-string len)) (let* ((s (make-string len))
(fd/port (optional-arg maybe-fd/port (current-input-port))) (fd/port (:optional maybe-fd/port (current-input-port)))
(nread (read-string! s fd/port 0 len))) (nread (read-string! s fd/port 0 len)))
(cond ((not nread) #f) ; EOF (cond ((not nread) #f) ; EOF
((= nread len) s) ((= nread len) s)
@ -140,10 +140,10 @@
s start start end target))) s start start end target)))
nwritten))))) nwritten)))))
(define (write-string/partial s . maybe-args) (define (write-string/partial s . args)
(receive (fd/port start end) (let-optionals args ((fd/port (current-output-port))
(parse-optionals maybe-args (start 0)
(current-output-port) 0 (string-length s)) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-write-string/partial s start end (generic-write-string/partial s start end
write-fdes-substring/errno fd/port)) write-fdes-substring/errno fd/port))
@ -171,10 +171,10 @@
s start i end target))) s start i end target)))
(loop (+ i nwritten))))))) (loop (+ i nwritten)))))))
(define (write-string s . maybe-args) (define (write-string s . args)
(receive (fd/port start end) (let-optionals args ((fd/port (current-output-port))
(parse-optionals maybe-args (start 0)
(current-output-port) 0 (string-length s)) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-write-string s start end (generic-write-string s start end
write-fdes-substring/errno fd/port)) write-fdes-substring/errno fd/port))
@ -193,8 +193,7 @@
(cond ((eof-object? line) (cond ((eof-object? line)
(newline) (newline)
(if (= count 0) (if (= count 0)
(optional-arg* maybe-eof-value (:optional maybe-eof-value (error "EOF in y-or-n?"))
(lambda () (error "EOF in y-or-n?")))
(begin (display "I'll only ask another ") (begin (display "I'll only ask another ")
(write count) (write count)
(display " times.") (display " times.")

1
scsh/scsh-interfaces.scm
View File

@ -543,7 +543,6 @@
(define-interface scsh-utilities-interface (define-interface scsh-utilities-interface
(export del delete index rindex reduce filter first any first? nth (export del delete index rindex reduce filter first any first? nth
any? every? mapv mapv! vector-every? copy-vector any? every? mapv mapv! vector-every? copy-vector
optional-arg optional-arg* parse-optionals
check-arg conjoin disjoin negate compose reverse! call/cc check-arg conjoin disjoin negate compose reverse! call/cc
deprecated-proc deprecated-proc
deposit-bit-field deposit-bit-field

11
scsh/scsh-package.scm
View File

@ -22,12 +22,16 @@
;;; -Olin ;;; -Olin
;;; The LET-OPT package for optional argument parsing & defaulting
;;; is found in the let-opt.scm file.
(define-structure error-package (export error warn) (define-structure error-package (export error warn)
(open signals)) (open signals))
(define-structure scsh-utilities scsh-utilities-interface (define-structure scsh-utilities scsh-utilities-interface
(open bitwise error-package scheme) (open bitwise error-package let-opt scheme)
(files utilities)) (files utilities))
@ -37,7 +41,7 @@
(open receiving ; receive (open receiving ; receive
error-package error-package
syntactic ; generated? syntactic ; generated?
scsh-utilities ; check-arg, optional-arg scsh-utilities ; check-arg
scheme scheme
) )
(files syntax-helpers)) (files syntax-helpers))
@ -55,6 +59,7 @@
define-foreign-syntax define-foreign-syntax
receiving receiving
error-package error-package
let-opt ; optional-arg parsing & defaulting
scheme) scheme)
(files re)) (files re))
@ -70,6 +75,7 @@
scsh-utilities scsh-utilities
error-package ; error error-package ; error
scsh-level-0 ; regexes and delimited readers scsh-level-0 ; regexes and delimited readers
let-opt ; optional-arg parsing & defaulting
scheme scheme
) )
(files fr)) (files fr))
@ -175,6 +181,7 @@
scsh-version scsh-version
tty-flags tty-flags
scsh-internal-tty-flags ; Not exported scsh-internal-tty-flags ; Not exported
let-opt ; optional-arg parsing & defaulting
scheme scheme
) )

6
scsh/scsh.scm
View File

@ -302,7 +302,7 @@
(define (temp-file-iterate maker . maybe-template) (define (temp-file-iterate maker . maybe-template)
(let ((template (optional-arg maybe-template (fluid *temp-file-template*)))) (let ((template (:optional maybe-template (fluid *temp-file-template*))))
(let loop ((i 0)) (let loop ((i 0))
(if (> i 1000) (error "Can't create temp-file") (if (> i 1000) (error "Can't create temp-file")
(let ((fname (format #f template (number->string i)))) (let ((fname (format #f template (number->string i))))
@ -538,7 +538,7 @@
(lp))))))) (lp)))))))
(define (string-filter filter . maybe-buflen) (define (string-filter filter . maybe-buflen)
(let* ((buflen (optional-arg maybe-buflen 1024)) (let* ((buflen (:optional maybe-buflen 1024))
(buf (make-string buflen))) (buf (make-string buflen)))
(lambda () (lambda ()
(let lp () (let lp ()
@ -694,7 +694,7 @@
(define (exit . maybe-status) (define (exit . maybe-status)
(flush-all-ports) (flush-all-ports)
(exit/errno (optional-arg maybe-status 0)) (exit/errno (:optional maybe-status 0))
(display "The evil undead walk the earth." 2) (display "The evil undead walk the earth." 2)
(error "(exit) returned.")) (error "(exit) returned."))

24
scsh/syntax-helpers.scm
View File

@ -1,7 +1,7 @@
;;; Macro expanding procs for scsh. ;;; Macro expanding procs for scsh.
;;; Written for Clinger/Rees explicit renaming macros. ;;; Written for Clinger/Rees explicit renaming macros.
;;; Needs name-export and receive-syntax S48 packages. ;;; Needs name-export and receive-syntax S48 packages.
;;; Also needs scsh's utilities package (optional-arg & check-arg). ;;; Also needs scsh's utilities package (for CHECK-ARG).
;;; Must be loaded into for-syntax package. ;;; Must be loaded into for-syntax package.
;;; Copyright (c) 1993 by Olin Shivers. ;;; Copyright (c) 1993 by Olin Shivers.
@ -145,28 +145,6 @@
(blockify `(,@redir-chunks ,pf-chunk) rename compare))) (blockify `(,@redir-chunks ,pf-chunk) rename compare)))
;;; These two utility funs are for parsing optional last arguments,
;;; e.g. the PORT arg in
;;; (write-string string [port])
;;; (define (write-string str . maybe-port) ...).
(define (optional-arg maybe-arg default)
(cond ((null? maybe-arg) default)
((null? (cdr maybe-arg)) (car maybe-arg))
(else (error "too many optional arguments" maybe-arg))))
(define (optional-arg* maybe-arg default-thunk)
(if (null? maybe-arg) (default-thunk) (car maybe-arg)))
(define (check-arg pred val caller)
(let lp ((val val))
(if (pred val) val
(lp (error "Bad argument" val))))) ; Loop doesn't really work.
(define (transcribe-redirection redir rename compare) (define (transcribe-redirection redir rename compare)
(let* ((backq (make-backquoter rename)) (let* ((backq (make-backquoter rename))
(parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form. (parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form.

8
scsh/time.scm
View File

@ -66,7 +66,7 @@
(define set-date:year-day set-%date:year-day) (define set-date:year-day set-%date:year-day)
(define (make-date s mi h md mo y . args) (define (make-date s mi h md mo y . args)
(receive (tzn tzs s? wd yd) (parse-optionals args #f #f #f 0 0) (let-optionals args ((tzn #f) (tzs #f) (s? #f) (wd 0) (yd 0))
(make-%date s mi h md mo y tzn tzs s? wd yd))) (make-%date s mi h md mo y tzn tzs s? wd yd)))
@ -160,7 +160,7 @@
(real->exact-integer (check-arg real? (car args) date)) (real->exact-integer (check-arg real? (car args) date))
(time))) (time)))
(zone (check-arg time-zone? (zone (check-arg time-zone?
(and (pair? args) (optional-arg (cdr args) #f)) (and (pair? args) (:optional (cdr args) #f))
date))) date)))
(receive (err seconds minute hour month-day month (receive (err seconds minute hour month-day month
year tz-name tz-secs summer? week-day year-day) year tz-name tz-secs summer? week-day year-day)
@ -222,14 +222,14 @@
; (real->exact-integer (check-arg real? (car args) utc-offset)) ; (real->exact-integer (check-arg real? (car args) utc-offset))
; (time))) ; (time)))
; (tz (and (pair? args) ; (tz (and (pair? args)
; (check-arg time-zone? (optional-arg (cdr args) #f) utc-offset)))) ; (check-arg time-zone? (:optional (cdr args) #f) utc-offset))))
; (if (integer? tz) tz ; (if (integer? tz) tz
; (- (time (date tim tz) 0) tim)))) ; (- (time (date tim tz) 0) tim))))
;(define (time-zone . args) ; Optional args [summer? tz] ;(define (time-zone . args) ; Optional args [summer? tz]
; (let ((tz (and (pair? args) ; (let ((tz (and (pair? args)
; (check-arg time-zone? (optional-arg (cdr args) #f) time-zone)))) ; (check-arg time-zone? (:optional (cdr args) #f) time-zone))))
; (if (integer? tz) ; (if (integer? tz)
; (deintegerize-time-zone tz) ; (deintegerize-time-zone tz)
; (let* ((summer? (if (pair? args) (car args) (time))) ; (let* ((summer? (if (pair? args) (car args) (time)))

4
scsh/tty.scm
View File

@ -223,7 +223,7 @@
(define (send-tty-break fdport . maybe-duration) (define (send-tty-break fdport . maybe-duration)
(call/fdes fdport (call/fdes fdport
(lambda (fdes) (lambda (fdes)
(%send-tty-break-fdes fdes (optional-arg maybe-duration 0))))) (%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
(define-errno-syscall (%send-tty-break-fdes fdes duration) (define-errno-syscall (%send-tty-break-fdes fdes duration)
%send-tty-break-fdes/errno) %send-tty-break-fdes/errno)
@ -344,7 +344,7 @@
;;; SunOS, and SVR4. ;;; SunOS, and SVR4.
(define (open-control-tty ttyname . maybe-flags) (define (open-control-tty ttyname . maybe-flags)
(let ((flags (optional-arg maybe-flags open/read+write))) (let ((flags (:optional maybe-flags open/read+write)))
(receive (errno fd) (open-control-tty/errno ttyname flags) (receive (errno fd) (open-control-tty/errno ttyname flags)
(if errno (if errno
(errno-error errno open-control-tty ttyname flags) (errno-error errno open-control-tty ttyname flags)

55
scsh/utilities.scm
View File

@ -17,7 +17,7 @@
(filter (lambda (x) (not (pred x))) lis)) (filter (lambda (x) (not (pred x))) lis))
(define (index str c . maybe-start) (define (index str c . maybe-start)
(let ((start (max 0 (optional-arg maybe-start 0))) (let ((start (max 0 (:optional maybe-start 0)))
(len (string-length str))) (len (string-length str)))
(do ((i start (+ 1 i))) (do ((i start (+ 1 i)))
((or (>= i len) ((or (>= i len)
@ -26,7 +26,7 @@
(define (rindex str c . maybe-start) (define (rindex str c . maybe-start)
(let* ((len (string-length str)) (let* ((len (string-length str))
(start (min (optional-arg maybe-start len) (start (min (:optional maybe-start len)
len))) len)))
(do ((i (- start 1) (- i 1))) (do ((i (- start 1) (- i 1)))
((or (< i 0) ((or (< i 0)
@ -109,57 +109,6 @@
((< i 0) ans) ((< i 0) ans)
(vector-set! ans i (vector-ref v i))))) (vector-set! ans i (vector-ref v i)))))
;;; These two utility funs are for parsing optional last arguments,
;;; e.g. the PORT arg in
;;; (write-string string [port])
;;; (define (write-string str . maybe-port) ...).
(define (optional-arg maybe-arg default)
(cond ((null? maybe-arg) default)
((null? (cdr maybe-arg)) (car maybe-arg))
(else (error "too many optional arguments" maybe-arg))))
(define (optional-arg* maybe-arg default-thunk)
(if (null? maybe-arg) (default-thunk) (car maybe-arg)))
;;; (PARSE-OPTIONALS arg-list . default-list)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This function generalises OPTIONAL-ARG to the multi-argument
;;; case. ARG-LIST is a list of rest args passed to a procedure.
;;; DEFAULT-LIST are the default values for the procedure.
;;; We compute a list of values, with the elts of ARG-LIST overriding
;;; the defaults. It is an error if there are more args than defaults.
;;; The values are returned as multiple values, suitable for binding
;;; with RECEIVE.
;;;
;;; Example:
;;; (define (read-string! str . maybe-args)
;;; (receive (port start end)
;;; (parse-optionals maybe-args
;;; (current-input-port) 0 (string-length str))
;;; ...))
(define (parse-optionals arg-list . default-list)
(let lp ((arglist arg-list)
(defaults default-list)
(vals '()))
(if (pair? defaults)
(if (pair? arglist)
;; The supplied arg overrides the default.
(lp (cdr arglist)
(cdr defaults)
(cons (car arglist) vals))
;; No more args. Use up all the remaining defaults & return.
(apply values (reverse (append (reverse defaults) vals))))
;; No more defaults. Better not be any more args.
(if (null? arglist)
(apply values (reverse vals))
(error "Too many optional arguments" arg-list)))))
(define (check-arg pred val caller) (define (check-arg pred val caller)
(if (pred val) val (if (pred val) val
(check-arg pred (error "Bad argument" val pred caller) caller))) (check-arg pred (error "Bad argument" val pred caller) caller)))