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:
parent
6b42e9d7aa
commit
ea45fca8ef
|
@ -82,7 +82,7 @@
|
|||
(create-file-thing new-fname
|
||||
(lambda (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))
|
||||
|
||||
|
@ -90,7 +90,7 @@
|
|||
(create-file-thing new-fname
|
||||
(lambda (symlink)
|
||||
(create-symlink/errno old-fname symlink))
|
||||
(optional-arg maybe-override? #f)
|
||||
(:optional maybe-override? #f)
|
||||
"create-symlink"
|
||||
create-symlink))
|
||||
|
||||
|
@ -103,7 +103,7 @@
|
|||
;;; us not to. That's life in the food chain.
|
||||
|
||||
(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)))
|
||||
(file-not-exists? new-fname)
|
||||
(and override?
|
||||
|
|
|
@ -67,7 +67,7 @@
|
|||
(define set-lock-region:pid set-%lock-region:pid)
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
|
|
|
@ -98,7 +98,7 @@
|
|||
|
||||
|
||||
(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.
|
||||
(w/slashes (if (pair? pathlist)
|
||||
(let insert-slashes ((pathlist pathlist))
|
||||
|
@ -162,7 +162,7 @@
|
|||
fname)))
|
||||
|
||||
(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))
|
||||
(len (string-length fname)))
|
||||
(if (zero? len) "/"
|
||||
|
|
|
@ -141,7 +141,7 @@
|
|||
;;; Except no MASK for now.
|
||||
|
||||
(define (%set-interrupt-handler interrupt handler . args)
|
||||
(receive (flags) (parse-optionals args 0)
|
||||
(let-optionals args ((flags 0))
|
||||
(receive (err handler flags)
|
||||
(%%set-interrupt-handler interrupt handler flags)
|
||||
(if err
|
||||
|
|
114
scsh/network.scm
114
scsh/network.scm
|
@ -143,8 +143,7 @@
|
|||
;;; socket syscall
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (create-socket pf type . maybe-protocol)
|
||||
(receive (protocol)
|
||||
(parse-optionals maybe-protocol 0)
|
||||
(let ((protocol (:optional maybe-protocol 0)))
|
||||
(if (not (and (integer? pf)
|
||||
(integer? type)
|
||||
(integer? protocol)))
|
||||
|
@ -366,8 +365,7 @@
|
|||
;;; recv syscall
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (receive-message socket len . maybe-flags)
|
||||
(receive (flags)
|
||||
(parse-optionals maybe-flags 0)
|
||||
(let ((flags (:optional maybe-flags 0)))
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message: socket expected ~s" socket))
|
||||
((or (not (integer? flags))
|
||||
|
@ -383,23 +381,22 @@
|
|||
(else (substring s 0 nread)))
|
||||
from)))))))
|
||||
|
||||
(define (receive-message! socket s . maybe-args)
|
||||
(define (receive-message! socket s . args)
|
||||
(if (not (string? s))
|
||||
(error "receive-message!: string expected ~s" s)
|
||||
(receive (start end flags)
|
||||
(parse-optionals maybe-args 0 (string-length s) 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!: socket expected ~s" socket))
|
||||
((not (or (integer? flags)
|
||||
(integer? start)
|
||||
(integer? end)))
|
||||
(error "receive-message!: integer expected ~s ~s ~s"
|
||||
flags start end))
|
||||
(else
|
||||
(generic-receive-message! (socket->fdes socket) flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
(socket:family socket)))))))
|
||||
(let-optionals args ((start 0) (end (string-length s)) (flags 0))
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!: socket expected ~s" socket))
|
||||
((not (or (integer? flags)
|
||||
(integer? start)
|
||||
(integer? end)))
|
||||
(error "receive-message!: integer expected ~s ~s ~s"
|
||||
flags start end))
|
||||
(else
|
||||
(generic-receive-message! (socket->fdes socket) flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
(socket:family socket)))))))
|
||||
|
||||
(define (generic-receive-message! sockfd flags s start end reader from)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
|
@ -424,8 +421,7 @@
|
|||
(else (loop (+ i nread)))))))))
|
||||
|
||||
(define (receive-message/partial socket len . maybe-flags)
|
||||
(receive (flags)
|
||||
(parse-optionals maybe-flags 0)
|
||||
(let ((flags (:optional maybe-flags 0)))
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message/partial: socket expected ~s" socket))
|
||||
((or (not (integer? flags))
|
||||
|
@ -441,23 +437,22 @@
|
|||
(else (substring s 0 nread)))
|
||||
addr)))))))
|
||||
|
||||
(define (receive-message!/partial socket s . maybe-args)
|
||||
(define (receive-message!/partial socket s . args)
|
||||
(if (not (string? s))
|
||||
(error "receive-message!/partial: string expected ~s" s)
|
||||
(receive (start end flags)
|
||||
(parse-optionals maybe-args 0 (string-length s) 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!/partial: socket expected ~s"
|
||||
socket))
|
||||
((not (integer? flags))
|
||||
(error "receive-message!/partial: integer expected ~s"
|
||||
flags))
|
||||
(else
|
||||
(generic-receive-message!/partial (socket->fdes socket)
|
||||
flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
(socket:family socket)))))))
|
||||
(let-optionals args ((start 0) (end (string-length s)) (flags 0))
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!/partial: socket expected ~s"
|
||||
socket))
|
||||
((not (integer? flags))
|
||||
(error "receive-message!/partial: integer expected ~s"
|
||||
flags))
|
||||
(else
|
||||
(generic-receive-message!/partial (socket->fdes socket)
|
||||
flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
(socket:family socket)))))))
|
||||
|
||||
(define (generic-receive-message!/partial sockfd flags s start end reader from)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
|
@ -493,10 +488,8 @@
|
|||
;;; send syscall
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
||||
(define (send-message socket s . maybe-args)
|
||||
(receive (start end flags addr)
|
||||
(parse-optionals maybe-args
|
||||
0 (string-length s) 0 #f)
|
||||
(define (send-message socket s . args)
|
||||
(let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
|
||||
(cond ((not (socket? socket))
|
||||
(error "send-message: socket expected ~s" socket))
|
||||
((not (integer? flags))
|
||||
|
@ -527,10 +520,8 @@
|
|||
s start i end writer)))
|
||||
(loop (+ i nwritten))))))))
|
||||
|
||||
(define (send-message/partial socket s . maybe-args)
|
||||
(receive (start end flags addr)
|
||||
(parse-optionals maybe-args
|
||||
0 (string-length s) 0 #f)
|
||||
(define (send-message/partial socket s . args)
|
||||
(let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
|
||||
(cond ((not (socket? socket))
|
||||
(error "send-message/partial: socket expected ~s" socket))
|
||||
((not (integer? flags))
|
||||
|
@ -837,13 +828,13 @@
|
|||
protocol) ; Protocol name
|
||||
|
||||
(define (service-info . args)
|
||||
(cond ((string? (car args)) (apply name->service-info args))
|
||||
((integer? (car args)) (apply port->service-info args))
|
||||
(else (error "service-info: string or integer expected ~s" args))))
|
||||
(apply (cond ((string? (car args)) name->service-info)
|
||||
((integer? (car args)) port->service-info)
|
||||
(else (error "service-info: string or integer expected ~s" args)))
|
||||
args))
|
||||
|
||||
(define (port->service-info name . maybe-proto)
|
||||
(receive (proto)
|
||||
(parse-optionals maybe-proto "")
|
||||
(let ((proto (:optional maybe-proto "")))
|
||||
(cond ((not (integer? name))
|
||||
(error "port->service-info: integer expected ~s" name))
|
||||
((not (string? proto))
|
||||
|
@ -851,11 +842,10 @@
|
|||
(else
|
||||
(receive (result name aliases port protocol)
|
||||
(%service-port->service-info name proto)
|
||||
(make-service-info name
|
||||
(vector->list
|
||||
(C-string-vec->Scheme aliases #f))
|
||||
port
|
||||
protocol))))))
|
||||
(make-service-info name
|
||||
(vector->list (C-string-vec->Scheme aliases #f))
|
||||
port
|
||||
protocol))))))
|
||||
|
||||
(define-foreign %service-port->service-info
|
||||
(scheme_serv_port2serv_info (integer name) (string proto))
|
||||
|
@ -867,18 +857,10 @@
|
|||
|
||||
|
||||
(define (name->service-info name . maybe-proto)
|
||||
(receive (proto)
|
||||
(parse-optionals maybe-proto "")
|
||||
(if (or (not (string? name))
|
||||
(not (string? name)))
|
||||
(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)))))
|
||||
(receive (result name aliases port protocol)
|
||||
(%service-name->service-info name (:optional maybe-proto ""))
|
||||
(make-service-info name (vector->list (C-string-vec->Scheme aliases #f))
|
||||
port protocol)))
|
||||
|
||||
(define-foreign %service-name->service-info
|
||||
(scheme_serv_name2serv_info (string name) (string proto))
|
||||
|
|
|
@ -135,7 +135,7 @@
|
|||
port))
|
||||
|
||||
(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))))
|
||||
|
||||
(define (open-output-file fname . rest)
|
||||
|
@ -291,7 +291,7 @@
|
|||
(define-simple-syntax
|
||||
(define-r4rs-input (name arg ...) stream s48name body ...)
|
||||
(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))
|
||||
((integer? stream) body ...)
|
||||
(else (error "Not a port or file descriptor" stream))))))
|
||||
|
@ -313,7 +313,7 @@
|
|||
(define-simple-syntax
|
||||
(define-r4rs-output (name arg ...) stream s48name body ...)
|
||||
(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))
|
||||
((integer? stream) body ...)
|
||||
(else (error "Not a port or file descriptor" stream))))))
|
||||
|
|
|
@ -35,7 +35,7 @@
|
|||
#f)))
|
||||
|
||||
(define (pid->proc pid . maybe-probe?)
|
||||
(let ((probe? (optional-arg maybe-probe? #f)))
|
||||
(let ((probe? (:optional maybe-probe? #f)))
|
||||
(or (maybe-pid->proc pid)
|
||||
(case probe?
|
||||
((#f) (error "Pid has no corresponding process object" pid))
|
||||
|
@ -155,7 +155,7 @@
|
|||
|
||||
(define (wait pid/proc . maybe-flags)
|
||||
(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)))
|
||||
(cond ((proc:%status proc) => ; Already reaped.
|
||||
(lambda (status)
|
||||
|
@ -176,17 +176,16 @@
|
|||
;;; (wait-any [flags]) -> [proc status]
|
||||
|
||||
(define (wait-any . maybe-flags)
|
||||
(let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait-any)))
|
||||
(if (not *autoreap-policy*) (reap-zombies))
|
||||
(cond ((get-reaped-proc!) => ; Check internal table.
|
||||
(lambda (proc) (values proc (proc:%status proc)))) ; Hit.
|
||||
(else
|
||||
(receive (pid status) (%wait-any flags) ; Really wait.
|
||||
(if pid
|
||||
(let ((proc (pid->proc pid)))
|
||||
(cache-wait-status proc status)
|
||||
(values proc status))
|
||||
(values pid status))))))) ; pid = #f -- Empty poll.
|
||||
(if (not *autoreap-policy*) (reap-zombies))
|
||||
(cond ((get-reaped-proc!) => ; Check internal table.
|
||||
(lambda (proc) (values proc (proc:%status proc)))) ; Hit.
|
||||
(else
|
||||
(receive (pid status) (%wait-any (:optional maybe-flags 0)) ; Wait.
|
||||
(if pid
|
||||
(let ((proc (pid->proc pid)))
|
||||
(cache-wait-status proc status)
|
||||
(values proc status))
|
||||
(values pid status)))))) ; pid = #f -- Empty poll.
|
||||
|
||||
|
||||
;;; (wait-process-group [proc-group flags])
|
||||
|
@ -195,8 +194,7 @@
|
|||
;;; early autoreaping, since the reaper loses process-group information.
|
||||
|
||||
(define (wait-process-group . args)
|
||||
(receive (proc-group flags) (parse-optionals args 0 0)
|
||||
(check-arg integer? flags wait-process-group)
|
||||
(let-optionals args ((proc-group 0) (flags 0))
|
||||
(if (not *autoreap-policy*) (reap-zombies))
|
||||
(let ((proc-group (cond ((integer? proc-group) proc-group)
|
||||
((proc? proc-group) (proc:pid proc-group))
|
||||
|
|
|
@ -16,14 +16,14 @@
|
|||
|
||||
(define (match:start match . maybe-index)
|
||||
(vector-ref (regexp-match:start match)
|
||||
(optional-arg maybe-index 0)))
|
||||
(:optional maybe-index 0)))
|
||||
|
||||
(define (match:end match . maybe-index)
|
||||
(vector-ref (regexp-match:end match)
|
||||
(optional-arg maybe-index 0)))
|
||||
(:optional maybe-index 0)))
|
||||
|
||||
(define (match:substring match . maybe-index)
|
||||
(let ((i (optional-arg maybe-index 0)))
|
||||
(let ((i (:optional maybe-index 0)))
|
||||
(substring (regexp-match:string match)
|
||||
(match:start match i)
|
||||
(match:end match i))))
|
||||
|
@ -38,7 +38,7 @@
|
|||
(define (make-regexp str) str)
|
||||
|
||||
(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))
|
||||
(end-vec (make-vector 10)))
|
||||
(and (%regexp-match regexp str start start-vec end-vec)
|
||||
|
|
39
scsh/rw.scm
39
scsh/rw.scm
|
@ -27,10 +27,10 @@
|
|||
s start start end source)))
|
||||
(and (not (zero? nread)) nread))))))
|
||||
|
||||
(define (read-string!/partial s . maybe-args)
|
||||
(receive (fd/port start end)
|
||||
(parse-optionals maybe-args
|
||||
(current-input-port) 0 (string-length s))
|
||||
(define (read-string!/partial s . args)
|
||||
(let-optionals args ((fd/port (current-input-port))
|
||||
(start 0)
|
||||
(end (string-length s)))
|
||||
(cond ((integer? fd/port)
|
||||
(generic-read-string!/partial s start end
|
||||
read-fdes-substring!/errno fd/port))
|
||||
|
@ -61,7 +61,7 @@
|
|||
|
||||
(define (read-string/partial len . maybe-fd/port)
|
||||
(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)))
|
||||
(cond ((not nread) #f) ; EOF
|
||||
((= nread len) s)
|
||||
|
@ -89,10 +89,10 @@
|
|||
|
||||
(else (loop (+ i nread))))))))
|
||||
|
||||
(define (read-string! s . maybe-args)
|
||||
(receive (fd/port start end)
|
||||
(parse-optionals maybe-args
|
||||
(current-input-port) 0 (string-length s))
|
||||
(define (read-string! s . args)
|
||||
(let-optionals args ((fd/port (current-input-port))
|
||||
(start 0)
|
||||
(end (string-length s)))
|
||||
(cond ((integer? fd/port)
|
||||
(generic-read-string! s start end
|
||||
read-fdes-substring!/errno fd/port))
|
||||
|
@ -114,7 +114,7 @@
|
|||
|
||||
(define (read-string len . maybe-fd/port)
|
||||
(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)))
|
||||
(cond ((not nread) #f) ; EOF
|
||||
((= nread len) s)
|
||||
|
@ -140,10 +140,10 @@
|
|||
s start start end target)))
|
||||
nwritten)))))
|
||||
|
||||
(define (write-string/partial s . maybe-args)
|
||||
(receive (fd/port start end)
|
||||
(parse-optionals maybe-args
|
||||
(current-output-port) 0 (string-length s))
|
||||
(define (write-string/partial s . args)
|
||||
(let-optionals args ((fd/port (current-output-port))
|
||||
(start 0)
|
||||
(end (string-length s)))
|
||||
(cond ((integer? fd/port)
|
||||
(generic-write-string/partial s start end
|
||||
write-fdes-substring/errno fd/port))
|
||||
|
@ -171,10 +171,10 @@
|
|||
s start i end target)))
|
||||
(loop (+ i nwritten)))))))
|
||||
|
||||
(define (write-string s . maybe-args)
|
||||
(receive (fd/port start end)
|
||||
(parse-optionals maybe-args
|
||||
(current-output-port) 0 (string-length s))
|
||||
(define (write-string s . args)
|
||||
(let-optionals args ((fd/port (current-output-port))
|
||||
(start 0)
|
||||
(end (string-length s)))
|
||||
(cond ((integer? fd/port)
|
||||
(generic-write-string s start end
|
||||
write-fdes-substring/errno fd/port))
|
||||
|
@ -193,8 +193,7 @@
|
|||
(cond ((eof-object? line)
|
||||
(newline)
|
||||
(if (= count 0)
|
||||
(optional-arg* maybe-eof-value
|
||||
(lambda () (error "EOF in y-or-n?")))
|
||||
(:optional maybe-eof-value (error "EOF in y-or-n?"))
|
||||
(begin (display "I'll only ask another ")
|
||||
(write count)
|
||||
(display " times.")
|
||||
|
|
|
@ -543,7 +543,6 @@
|
|||
(define-interface scsh-utilities-interface
|
||||
(export del delete index rindex reduce filter first any first? nth
|
||||
any? every? mapv mapv! vector-every? copy-vector
|
||||
optional-arg optional-arg* parse-optionals
|
||||
check-arg conjoin disjoin negate compose reverse! call/cc
|
||||
deprecated-proc
|
||||
deposit-bit-field
|
||||
|
|
|
@ -22,12 +22,16 @@
|
|||
;;; -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)
|
||||
(open signals))
|
||||
|
||||
|
||||
(define-structure scsh-utilities scsh-utilities-interface
|
||||
(open bitwise error-package scheme)
|
||||
(open bitwise error-package let-opt scheme)
|
||||
(files utilities))
|
||||
|
||||
|
||||
|
@ -37,7 +41,7 @@
|
|||
(open receiving ; receive
|
||||
error-package
|
||||
syntactic ; generated?
|
||||
scsh-utilities ; check-arg, optional-arg
|
||||
scsh-utilities ; check-arg
|
||||
scheme
|
||||
)
|
||||
(files syntax-helpers))
|
||||
|
@ -55,6 +59,7 @@
|
|||
define-foreign-syntax
|
||||
receiving
|
||||
error-package
|
||||
let-opt ; optional-arg parsing & defaulting
|
||||
scheme)
|
||||
(files re))
|
||||
|
||||
|
@ -70,6 +75,7 @@
|
|||
scsh-utilities
|
||||
error-package ; error
|
||||
scsh-level-0 ; regexes and delimited readers
|
||||
let-opt ; optional-arg parsing & defaulting
|
||||
scheme
|
||||
)
|
||||
(files fr))
|
||||
|
@ -175,6 +181,7 @@
|
|||
scsh-version
|
||||
tty-flags
|
||||
scsh-internal-tty-flags ; Not exported
|
||||
let-opt ; optional-arg parsing & defaulting
|
||||
|
||||
scheme
|
||||
)
|
||||
|
|
|
@ -302,7 +302,7 @@
|
|||
|
||||
|
||||
(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))
|
||||
(if (> i 1000) (error "Can't create temp-file")
|
||||
(let ((fname (format #f template (number->string i))))
|
||||
|
@ -538,7 +538,7 @@
|
|||
(lp)))))))
|
||||
|
||||
(define (string-filter filter . maybe-buflen)
|
||||
(let* ((buflen (optional-arg maybe-buflen 1024))
|
||||
(let* ((buflen (:optional maybe-buflen 1024))
|
||||
(buf (make-string buflen)))
|
||||
(lambda ()
|
||||
(let lp ()
|
||||
|
@ -694,7 +694,7 @@
|
|||
|
||||
(define (exit . maybe-status)
|
||||
(flush-all-ports)
|
||||
(exit/errno (optional-arg maybe-status 0))
|
||||
(exit/errno (:optional maybe-status 0))
|
||||
(display "The evil undead walk the earth." 2)
|
||||
(error "(exit) returned."))
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
;;; Macro expanding procs for scsh.
|
||||
;;; Written for Clinger/Rees explicit renaming macros.
|
||||
;;; 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.
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
|
@ -145,28 +145,6 @@
|
|||
(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)
|
||||
(let* ((backq (make-backquoter rename))
|
||||
(parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form.
|
||||
|
|
|
@ -66,7 +66,7 @@
|
|||
(define set-date:year-day set-%date:year-day)
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
|
@ -160,7 +160,7 @@
|
|||
(real->exact-integer (check-arg real? (car args) date))
|
||||
(time)))
|
||||
(zone (check-arg time-zone?
|
||||
(and (pair? args) (optional-arg (cdr args) #f))
|
||||
(and (pair? args) (:optional (cdr args) #f))
|
||||
date)))
|
||||
(receive (err seconds minute hour month-day month
|
||||
year tz-name tz-secs summer? week-day year-day)
|
||||
|
@ -222,14 +222,14 @@
|
|||
; (real->exact-integer (check-arg real? (car args) utc-offset))
|
||||
; (time)))
|
||||
; (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
|
||||
; (- (time (date tim tz) 0) tim))))
|
||||
|
||||
|
||||
;(define (time-zone . args) ; Optional args [summer? tz]
|
||||
; (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)
|
||||
; (deintegerize-time-zone tz)
|
||||
; (let* ((summer? (if (pair? args) (car args) (time)))
|
||||
|
|
|
@ -223,7 +223,7 @@
|
|||
(define (send-tty-break fdport . maybe-duration)
|
||||
(call/fdes fdport
|
||||
(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)
|
||||
%send-tty-break-fdes/errno)
|
||||
|
@ -344,7 +344,7 @@
|
|||
;;; SunOS, and SVR4.
|
||||
|
||||
(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)
|
||||
(if errno
|
||||
(errno-error errno open-control-tty ttyname flags)
|
||||
|
|
|
@ -17,7 +17,7 @@
|
|||
(filter (lambda (x) (not (pred x))) lis))
|
||||
|
||||
(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)))
|
||||
(do ((i start (+ 1 i)))
|
||||
((or (>= i len)
|
||||
|
@ -26,7 +26,7 @@
|
|||
|
||||
(define (rindex str c . maybe-start)
|
||||
(let* ((len (string-length str))
|
||||
(start (min (optional-arg maybe-start len)
|
||||
(start (min (:optional maybe-start len)
|
||||
len)))
|
||||
(do ((i (- start 1) (- i 1)))
|
||||
((or (< i 0)
|
||||
|
@ -109,57 +109,6 @@
|
|||
((< i 0) ans)
|
||||
(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)
|
||||
(if (pred val) val
|
||||
(check-arg pred (error "Bad argument" val pred caller) caller)))
|
||||
|
|
Loading…
Reference in New Issue