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
(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?

2
scsh/flock.scm
View File

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

4
scsh/fname.scm
View File

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

2
scsh/jcontrol2.scm
View File

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

58
scsh/network.scm
View File

@ -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,11 +381,10 @@
(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)
(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)
@ -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,11 +437,10 @@
(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)
(let-optionals args ((start 0) (end (string-length s)) (flags 0))
(cond ((not (socket? socket))
(error "receive-message!/partial: socket expected ~s"
socket))
@ -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))
@ -852,8 +843,7 @@
(receive (result name aliases port protocol)
(%service-port->service-info name proto)
(make-service-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(vector->list (C-string-vec->Scheme aliases #f))
port
protocol))))))
@ -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)))))
(%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))

6
scsh/newports.scm
View File

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

12
scsh/procobj.scm
View File

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

8
scsh/re.scm
View File

@ -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
View File

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

1
scsh/scsh-interfaces.scm
View File

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

11
scsh/scsh-package.scm
View File

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

6
scsh/scsh.scm
View File

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

24
scsh/syntax-helpers.scm
View File

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

8
scsh/time.scm
View File

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

4
scsh/tty.scm
View File

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

55
scsh/utilities.scm
View File

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