diff --git a/scsh/filesys.scm b/scsh/filesys.scm index 599b14c..c9d7127 100644 --- a/scsh/filesys.scm +++ b/scsh/filesys.scm @@ -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? diff --git a/scsh/flock.scm b/scsh/flock.scm index 474e4ee..973d464 100644 --- a/scsh/flock.scm +++ b/scsh/flock.scm @@ -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))) diff --git a/scsh/fname.scm b/scsh/fname.scm index 740623d..6072377 100644 --- a/scsh/fname.scm +++ b/scsh/fname.scm @@ -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) "/" diff --git a/scsh/jcontrol2.scm b/scsh/jcontrol2.scm index 1caaf98..b09ae2f 100644 --- a/scsh/jcontrol2.scm +++ b/scsh/jcontrol2.scm @@ -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 diff --git a/scsh/network.scm b/scsh/network.scm index 3af8b85..62053e8 100644 --- a/scsh/network.scm +++ b/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)) diff --git a/scsh/newports.scm b/scsh/newports.scm index 83401f9..d7c6369 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -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)))))) diff --git a/scsh/procobj.scm b/scsh/procobj.scm index 471eae0..972cd50 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -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)) diff --git a/scsh/re.scm b/scsh/re.scm index 7411799..0def23b 100644 --- a/scsh/re.scm +++ b/scsh/re.scm @@ -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) diff --git a/scsh/rw.scm b/scsh/rw.scm index 3fb4962..570a3f5 100644 --- a/scsh/rw.scm +++ b/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.") diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index 4053184..4741911 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -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 diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index e2c5d41..0043269 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -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 ) diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 357c23a..87498e5 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -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.")) diff --git a/scsh/syntax-helpers.scm b/scsh/syntax-helpers.scm index 3bda1d5..71efd6a 100644 --- a/scsh/syntax-helpers.scm +++ b/scsh/syntax-helpers.scm @@ -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. diff --git a/scsh/time.scm b/scsh/time.scm index 5016eab..5398d5f 100644 --- a/scsh/time.scm +++ b/scsh/time.scm @@ -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))) diff --git a/scsh/tty.scm b/scsh/tty.scm index f4c9b45..f0584c8 100644 --- a/scsh/tty.scm +++ b/scsh/tty.scm @@ -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) diff --git a/scsh/utilities.scm b/scsh/utilities.scm index 6952fd4..7fca411 100644 --- a/scsh/utilities.scm +++ b/scsh/utilities.scm @@ -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)))