New, improved let-opt. More features.
But I have a whole different design for handling optional args, so this will all go away at some point.
This commit is contained in:
olin-shivers
parent
d17b4b675e
commit
c1b9253b70
691
scsh/let-opt.scm
691
scsh/let-opt.scm
|
|
@ -1,45 +1,66 @@
|
|||
;;; LET-OPTIONALS macros
|
||||
;;; Copyright (c) 2001 by Olin Shivers.
|
||||
;;; See file COPYING.
|
||||
|
||||
;;; This file defines three macros for parsing optional arguments to procs:
|
||||
;;; (LET-OPTIONALS arg-list ((var1 default1) ...) . body)
|
||||
;;; (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
|
||||
;;; (:OPTIONAL rest-arg default-exp)
|
||||
;;; (LET-OPTIONALS arg-list (opt-clause1 ... opt-clauseN [rest])
|
||||
;;; body ...)
|
||||
;;; (LET-OPTIONALS* arg-list (opt-clause1 ... opt-clauseN [rest])
|
||||
;;; body ...)
|
||||
;;; (:OPTIONAL rest-arg default-exp [arg-check])
|
||||
;;; where
|
||||
;;; <opt-clause> ::= (var default [arg-check supplied?])
|
||||
;;; | ((var1 ... varN) external-arg-parser)
|
||||
;;;
|
||||
;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
|
||||
;;; explicit-renaming low-level macro system. You'll have to do some work to
|
||||
;;; port it to another macro system.
|
||||
;;; LET-OPTIONALS* has LET* scope -- each arg clause sees the bindings of
|
||||
;;; the previous clauses. LET-OPTIONALS has LET scope -- each arg clause
|
||||
;;; sees the outer scope (an ARG-CHECK expression sees the outer scope
|
||||
;;; *plus* the variable being bound by that clause, by necessity).
|
||||
;;;
|
||||
;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
|
||||
;;; high-level macros, and should be portable to any R4RS system.
|
||||
;;;
|
||||
;;; These macros are all careful to evaluate their default forms *only* if
|
||||
;;; their values are needed.
|
||||
;;;
|
||||
;;; The top-level forms in this file are Scheme 48 module expressions.
|
||||
;;; I use the module system to help me break up the expander code for
|
||||
;;; LET-OPTIONALS into three procedures, which makes it easier to understand
|
||||
;;; and test. But if you wanted to port this code to a module-less Scheme
|
||||
;;; system, you'd probably have to inline the three procs into the actual
|
||||
;;; macro definition.
|
||||
;;; In practice, LET-OPTIONALS* is the one you want.
|
||||
;;;
|
||||
;;; The only interesting module that is exported by this file is
|
||||
;;; LET-OPT
|
||||
;;; which obeys the following interface:
|
||||
;;; (exports (let-optionals :syntax)
|
||||
;;; (let-optionals* :syntax)
|
||||
;;; (:optional :syntax))
|
||||
;;; (:optional :syntax))
|
||||
;;;
|
||||
;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
|
||||
;;; explicit-renaming low-level macro system. You'll have to do some work to
|
||||
;;; port it to another macro system.
|
||||
;;;
|
||||
;;; The :OPTIONAL macro is defined with simple high-level macros,
|
||||
;;; and should be portable to any R4RS system.
|
||||
;;;
|
||||
;;; These macros are all careful to evaluate their default forms *only* if
|
||||
;;; their values are needed.
|
||||
;;;
|
||||
;;; The LET-OPTIONALS expander is pretty hairy. Sorry. It does produce
|
||||
;;; very good code.
|
||||
;;;
|
||||
;;; The top-level forms in this file are Scheme 48 module expressions.
|
||||
;;; I use the module system to help me break up the expander code for
|
||||
;;; LET-OPTIONALS into three procedures, which makes it easier to understand
|
||||
;;; and test. But if you wanted to port this code to a module-less Scheme
|
||||
;;; system, you'd probably have to inline the auxiliary procs into the actual
|
||||
;;; macro definition.
|
||||
;;;
|
||||
;;; To repeat: This code is not simple Scheme code; it is module code.
|
||||
;;; It must be loaded into the Scheme 48 ,config package, not the ,user
|
||||
;;; package.
|
||||
;;;
|
||||
;;; The only non-R4RS dependencies in the macros are ERROR
|
||||
;;; The only non-R4RS dependencies in the macros are ERROR, RECEIVE,
|
||||
;;; and CALL-WITH-VALUES.
|
||||
;;;
|
||||
;;; See below for details on each macro.
|
||||
;;; -Olin
|
||||
|
||||
;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
|
||||
;;; body
|
||||
;;; ...)
|
||||
;;; (LET-OPTIONALS* arg-list (clause ... [rest]) body ...)
|
||||
;;; (LET-OPTIONALS arg-list (clause ... [rest]) body ...)
|
||||
;;;
|
||||
;;; clause ::= (var default [arg-test supplied?]) ; The simple case
|
||||
;;; | ((var1 ...) external-arg-parser) ; external hook
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This form is for binding a procedure's optional arguments to either
|
||||
;;; the passed-in values or a default.
|
||||
|
|
@ -49,130 +70,385 @@
|
|||
;;; the remaining VARi are bound to their corresponding DEFAULTi values.
|
||||
;;; It is an error if there are more args than variables.
|
||||
;;;
|
||||
;;; Simple example:
|
||||
;;; (let-optionals* args ((in (current-input-port))
|
||||
;;; (out (current-output-port))
|
||||
;;; (nbytes (string-length s)))
|
||||
;;; ...)
|
||||
;;;
|
||||
;;; - The default expressions are *not* evaluated unless needed.
|
||||
;;;
|
||||
;;; - When evaluated, the default expressions are carried out in the *outer*
|
||||
;;; environment. That is, the DEFAULTi forms do *not* see any of the VARi
|
||||
;;; bindings.
|
||||
;;; - When a LET-OPTIONALS* form is evaluated, the default expressions are
|
||||
;;; carried out in a "sequential" LET*-style scope -- each clause is
|
||||
;;; evaluated in a scope that sees the bindings introduced by the previous
|
||||
;;; clauses.
|
||||
;;;
|
||||
;;; I originally wanted to have the DEFAULTi forms get eval'd in a LET*
|
||||
;;; style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
|
||||
;;; impossible to implement without side effects or redundant conditional
|
||||
;;; tests. If I drop this requirement, I can use the efficient expansion
|
||||
;;; shown below. If you need LET* scope, use the less-efficient
|
||||
;;; LET-OPTIONALS* form defined below.
|
||||
;;; - LET-OPTIONALS, in contrast, evaluates all clauses in the *outer*
|
||||
;;; environment. Each ARG-TEST form, however, does see the variable
|
||||
;;; bound by that clause (see below).
|
||||
;;;
|
||||
;;; - If there's an ARG-TEST form, it is evaluated when an argument is
|
||||
;;; passed in; it is not evaluated when the argument is defaulted.
|
||||
;;; If it produces false, an error is raised. You can stick an arg-checking
|
||||
;;; expression here. Here's the above example with full arg-checking:
|
||||
;;; (let ((strlen (string-length s)))
|
||||
;;; (let-optionals args ((in (current-input-port) (input-port? in))
|
||||
;;; (out (current-output-port) (output-port? out))
|
||||
;;; (nbytes strlen (and (integer? nbytes)
|
||||
;;; (< -1 nbytes strlen))))
|
||||
;;; ...))
|
||||
;;;
|
||||
;;; The ARG-TEST expression is evaluated in the outer scope of the LET,
|
||||
;;; plus a binding for the parameter being checked.
|
||||
;;;
|
||||
;;; - A SUPPLIED? variable is bound to true/false depending on whether or
|
||||
;;; not a value was passed in by the caller for this parameter.
|
||||
;;;
|
||||
;;; - If there's a final REST variable in the binding list, it is bound
|
||||
;;; to any leftover unparsed values from ARG-LIST. If there isn't a final
|
||||
;;; REST var, it is an error to have extra values left. You can use this
|
||||
;;; feature to parse a couple of arguments with LET-OPTIONALS, and handle
|
||||
;;; following args with some other mechanism. It is also useful for
|
||||
;;; procedures whose final arguments are homogeneous.
|
||||
;;;
|
||||
;;; - A clause of the form ((var1 ... varn) external-arg-parser) allows you
|
||||
;;; to parse & arg-check a group of arguments together. EXTERNAL-ARG-PARSER
|
||||
;;; is applied to the argument list. It returns n+1 values: one
|
||||
;;; for the leftover argument list, and one for each VARi.
|
||||
;;;
|
||||
;;; This facility is intended for things like substring start/end index
|
||||
;;; pairs. You can abstract out the code for parsing the pair of arguments
|
||||
;;; in a separate procedure (parse-substring-index-args args string proc)
|
||||
;;; and then a function such as READ-STRING! can simply invoke the procedure
|
||||
;;; with a
|
||||
;;; ((start end) (lambda (args) (parse-substring-index-args args s read-string!)))
|
||||
;;; clause. That is, the external-arg parser facility is a hook
|
||||
;;; that lets you interface other arg parsers into LET-OPTIONALS.
|
||||
|
||||
;;; Expanding the form
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; We expand the form into a code DAG that avoids repeatedly testing the
|
||||
;;; arg list once it runs out, but still shares code. For example,
|
||||
;;;
|
||||
;;; Example:
|
||||
;;; (define (read-string! str . maybe-args)
|
||||
;;; (let-optionals maybe-args ((port (current-input-port))
|
||||
;;; (start 0)
|
||||
;;; (end (string-length str)))
|
||||
;;; (let-optionals* maybe-args ((port (current-input-port))
|
||||
;;; (start 0)
|
||||
;;; (end (string-length str)))
|
||||
;;; ...))
|
||||
;;;
|
||||
;;; expands to:
|
||||
;;;
|
||||
;;; (let* ((body (lambda (port start end) ...))
|
||||
;;; (end-def (lambda (%port %start) (body %port %start <end-default>)))
|
||||
;;; (start-def (lambda (%port) (end-def %port <start-default>)))
|
||||
;;; (end-def (lambda (port start) (body port start <end-default>)))
|
||||
;;; (start-def (lambda (port) (end-def port <start-default>)))
|
||||
;;; (port-def (lambda () (start-def <port-def>))))
|
||||
;;; (if (null? rest) (port-def)
|
||||
;;; (let ((%port (car rest))
|
||||
;;; (rest (cdr rest)))
|
||||
;;; (if (null? rest) (start-def %port)
|
||||
;;; (let ((%start (car rest))
|
||||
;;; (rest (cdr rest)))
|
||||
;;; (if (null? rest) (end-def %port %start)
|
||||
;;; (let ((%end (car rest))
|
||||
;;; (rest (cdr rest)))
|
||||
;;; (if (null? rest) (body %port %start %end)
|
||||
;;; (error ...)))))))))
|
||||
;;; (if (pair? tail)
|
||||
;;; (let ((port (car tail))
|
||||
;;; (tail (cdr tail)))
|
||||
;;; (if (pair? tail)
|
||||
;;; (let ((start (car tail))
|
||||
;;; (tail (cdr tail)))
|
||||
;;; (if (pair? tail)
|
||||
;;; (let ((end (car tail))
|
||||
;;; (tail (cdr tail)))
|
||||
;;; (if (pair? tail)
|
||||
;;; (error ...)
|
||||
;;; (body port start end)))
|
||||
;;; (end-def port start)))
|
||||
;;; (start-def port)))
|
||||
;;; (port-def)))
|
||||
;;;
|
||||
;;; Note that the defaulter code (the chain of ...-DEF procs) is just a
|
||||
;;; linear sequence of machine code into which the IF-tree branches. Once
|
||||
;;; we jump into the defaulter chain, we never test the arg list again.
|
||||
;;; A reasonable compiler can turn this into optimal parameter-parsing code.
|
||||
|
||||
|
||||
(define-structure let-opt-expanders (export expand-let-optionals)
|
||||
(open scheme)
|
||||
(define-structure let-opt-expanders (export expand-let-optionals
|
||||
expand-let-optionals*)
|
||||
(open scheme
|
||||
error-package
|
||||
receiving)
|
||||
(begin
|
||||
|
||||
(define (make-gensym prefix)
|
||||
(let ((counter 0))
|
||||
(lambda ()
|
||||
(set! counter (+ counter 1))
|
||||
(string->symbol (string-append prefix (number->string counter))))))
|
||||
|
||||
;;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
|
||||
;;; If an elt of VARS is a list, we are dealing with a group-parser clause.
|
||||
;;; In this case, the corresponding element of DEFS is the name of
|
||||
;;; the parser.
|
||||
;;; I wish I had a reasonable loop macro.
|
||||
;;;
|
||||
;;; DEFAULTER-NAMES also holds the xparser expressions
|
||||
;;; - STAR? true
|
||||
;;; LET* scope semantics -- default I & xparser I are evaluated in
|
||||
;;; a scope that sees vars 1 ... I-1.
|
||||
;;; - STAR? false
|
||||
;;; LET scope semantics -- default and xparser forms don't see any of the
|
||||
;;; vars.
|
||||
;;;
|
||||
;;; I considered documenting this procedure better, but finally decided
|
||||
;;; that if it was this hard for me to write, it should be hard for you
|
||||
;;; to read. -Olin
|
||||
|
||||
(define (make-default-procs vars body-proc defaulter-names defs rename)
|
||||
(let ((%lambda (rename 'lambda)))
|
||||
(let recur ((vars (reverse vars))
|
||||
(defaulter-names (reverse defaulter-names))
|
||||
(defs (reverse defs))
|
||||
(next-guy body-proc))
|
||||
(if (null? vars) '()
|
||||
(let ((vars (cdr vars)))
|
||||
`((,(car defaulter-names)
|
||||
(,%lambda ,(reverse vars)
|
||||
(,next-guy ,@(reverse vars) ,(car defs))))
|
||||
. ,(recur vars
|
||||
(cdr defaulter-names)
|
||||
(cdr defs)
|
||||
(car defaulter-names))))))))
|
||||
(define (make-default-procs vars body-proc defaulter-names defs
|
||||
sup-vars rest-var star? rename)
|
||||
(receive (defaulters ignore-me and-me-too)
|
||||
(really-make-default-procs vars body-proc defaulter-names defs
|
||||
sup-vars rest-var star? rename)
|
||||
(reverse defaulters)))
|
||||
|
||||
(define (really-make-default-procs vars body-proc defaulter-names defs
|
||||
sup-vars rest-var star? rename)
|
||||
(let ((%lambda (rename 'lambda))
|
||||
(%let (rename 'let))
|
||||
(%ignore (rename '_))
|
||||
(%call/values (rename 'call-with-values))
|
||||
(tail (rename 'tail))
|
||||
(make-rv (let ((g (make-gensym "%ov.")))
|
||||
(lambda x (rename (g)))))
|
||||
(make-sv (let ((g (make-gensym "%sv.")))
|
||||
(lambda () (rename (g))))))
|
||||
|
||||
;; RECUR returns 2 values: a LET*-binding list of defaulter proc
|
||||
;; bindings, and an expression to evaluate in their scope.
|
||||
(let recur ((vars vars)
|
||||
(rev-params '()) ; These guys
|
||||
(rev-vals '()) ; have these values.
|
||||
(sup-vars sup-vars)
|
||||
(rev-sup-params '()) ; These guys
|
||||
(rev-sup-vals '()) ; have these values.
|
||||
(defaulter-names defaulter-names)
|
||||
(defs defs))
|
||||
;; Note that the #F's bound to the SUPPLIED? parameters have no
|
||||
;; effects, and so commute with the evaluation of the defaults.
|
||||
;; Hence we don't need the VALS-EVALED? trick for them, just for the
|
||||
;; default forms & their parameters.
|
||||
(if (pair? vars)
|
||||
(let* ((var (car vars)) (vars (cdr vars)) ; "VAR" is really a list
|
||||
(def (car defs)) (defs (cdr defs)) ; in xparser case...
|
||||
(rvar (if star? var ; scope control
|
||||
(if (pair? var) (map make-rv var) (make-rv))))
|
||||
(rev-params1 (if (pair? rvar)
|
||||
(append (reverse rvar) rev-params)
|
||||
(cons rvar rev-params)))
|
||||
(rev-vals1 (if (pair? rvar) rev-params1
|
||||
(cons def rev-params)))
|
||||
(sv (car sup-vars))
|
||||
(sv (if (or star? (not sv)) sv (make-sv)))
|
||||
(rev-sup-params1 (if sv (cons sv rev-sup-params)
|
||||
rev-sup-params))
|
||||
(rev-sup-vals1 (cond (sv (cons #f rev-sup-params))
|
||||
((pair? var) rev-sup-vals)
|
||||
(else rev-sup-params)))
|
||||
(defaulter (car defaulter-names))
|
||||
(defaulter-names (cdr defaulter-names)))
|
||||
(receive (procs exp vals-evaled?)
|
||||
(recur vars rev-params1 rev-vals1 (cdr sup-vars)
|
||||
rev-sup-params1 rev-sup-vals1
|
||||
defaulter-names defs)
|
||||
(if (pair? var)
|
||||
;; Return #f for VALS-EVALED? so we'll force any prior
|
||||
;; default to be eval'd & not pushed below this default eval.
|
||||
(values procs
|
||||
`(,%call/values (,%lambda () (,defaulter '()))
|
||||
(,%lambda ,(cons %ignore rvar) ,exp))
|
||||
#f)
|
||||
|
||||
(let ((params (reverse (append rev-sup-params rev-params)))
|
||||
(exp (if vals-evaled? exp
|
||||
`(,%let ((,rvar ,def)) ,exp))))
|
||||
(values `((,defaulter (,%lambda ,params ,exp))
|
||||
. ,procs)
|
||||
`(,defaulter ,@(reverse rev-vals)
|
||||
,@(reverse rev-sup-vals))
|
||||
#t)))))
|
||||
|
||||
(values '() `(,body-proc ,@(if rest-var '('()) '())
|
||||
,@(reverse rev-vals)
|
||||
. ,(reverse rev-sup-vals))
|
||||
#t)))))
|
||||
|
||||
|
||||
;;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
|
||||
|
||||
(define (make-if-tree vars defaulters body-proc rest rename)
|
||||
;;; This guy makes the (IF (PAIR? TAIL) ... (PORT-DEF)) tree above.
|
||||
;;; DEFAULTERS is a list of the names of the defaulter procs & the xparser
|
||||
;;; forms.
|
||||
|
||||
(define (make-if-tree vars defaulters arg-tests body-proc
|
||||
tail supvars rest-var star? rename)
|
||||
(let ((%if (rename 'if))
|
||||
(%null? (rename 'null?))
|
||||
(%pair? (rename 'pair?))
|
||||
(%not (rename 'not))
|
||||
(%error (rename 'error))
|
||||
(%let (rename 'let))
|
||||
(%lambda (rename 'lambda))
|
||||
(%call/values (rename 'call-with-values))
|
||||
(%car (rename 'car))
|
||||
(%cdr (rename 'cdr)))
|
||||
(%cdr (rename 'cdr))
|
||||
(make-rv (let ((g (make-gensym "%ov.")))
|
||||
(lambda x (rename (g))))))
|
||||
|
||||
(let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
|
||||
(let recur ((vars vars) (defaulters defaulters)
|
||||
(ats arg-tests) (non-defaults '())
|
||||
(supvars supvars) (sup-trues '()))
|
||||
(if (null? vars)
|
||||
`(,%if (,%null? ,rest) (,body-proc . ,(reverse non-defaults))
|
||||
(,%error "Too many optional arguments." ,rest))
|
||||
(if rest-var
|
||||
`(,body-proc ,tail ,@(reverse non-defaults) . ,sup-trues)
|
||||
`(,%if (,%pair? ,tail)
|
||||
(,%error "Too many optional arguments." ,tail)
|
||||
(,body-proc ,@(reverse non-defaults) . ,sup-trues)))
|
||||
|
||||
(let ((v (car vars)))
|
||||
`(,%if (,%null? ,rest)
|
||||
(,(car defaulters) . ,(reverse non-defaults))
|
||||
(,%let ((,v (,%car ,rest))
|
||||
(,rest (,%cdr ,rest)))
|
||||
,(recur (cdr vars)
|
||||
(cdr defaulters)
|
||||
(cons v non-defaults)))))))))
|
||||
(let* ((v (car vars))
|
||||
(rv (if star? v ; Scope control
|
||||
(if (pair? v) (map make-rv v) (make-rv))))
|
||||
(at (car ats))
|
||||
(sup-trues1 (if (car supvars) (cons #t sup-trues) sup-trues))
|
||||
|
||||
(body `(,@(if (not (eq? at #t))
|
||||
(let ((test (if star? at
|
||||
`(,%let ((,v ,rv)) ,at))))
|
||||
`((,%if (,%not ,test)
|
||||
(,%error "Optional argument failed test"
|
||||
',at ',v ,rv))))
|
||||
'()) ; No arg test
|
||||
,(recur (cdr vars)
|
||||
(cdr defaulters)
|
||||
(cdr ats)
|
||||
(if (pair? rv)
|
||||
(append (reverse rv) non-defaults)
|
||||
(cons rv non-defaults))
|
||||
(cdr supvars) sup-trues1))))
|
||||
(if (pair? rv)
|
||||
`(,%call/values (,%lambda ()
|
||||
(,(car defaulters) ,tail))
|
||||
(,%lambda (,tail . ,rv) . ,body))
|
||||
|
||||
`(,%if (,%pair? ,tail)
|
||||
(,%let ((,rv (,%car ,tail))
|
||||
(,tail (,%cdr ,tail)))
|
||||
. ,body)
|
||||
(,(car defaulters) ,@(reverse non-defaults) . ,sup-trues))))))))
|
||||
|
||||
|
||||
(define (expand-let-optionals exp rename compare?)
|
||||
;;; Parse the clauses into
|
||||
;;; - a list of vars,
|
||||
;;; - a list of defaults,
|
||||
;;; - a list of possible arg-tests. No arg-test is represented as #T.
|
||||
;;; - a list of possible SUPPLIED? vars. An elt is either (var) or #f.
|
||||
;;; - either the rest var or #f
|
||||
;;;
|
||||
;;; This is written out in painful detail so that we can do a lot of
|
||||
;;; syntax checking.
|
||||
|
||||
(define (parse-clauses bindings)
|
||||
;; LIST-LIB defines EVERY... but uses LET-OPTIONALS.
|
||||
;; Define here to break the dependency loop:
|
||||
(define (every pred lis)
|
||||
(or (not (pair? lis)) (and (pred (car lis)) (every pred (car lis)))))
|
||||
|
||||
(cond ((pair? bindings)
|
||||
(let ((rev (reverse bindings)))
|
||||
(receive (rest-var rev) (if (symbol? (car rev))
|
||||
(values (car rev) (cdr rev))
|
||||
(values #f rev))
|
||||
(receive (vars defs ats supvars)
|
||||
(let recur ((bindings (reverse rev)))
|
||||
(if (not (pair? bindings))
|
||||
(values '() '() '() '())
|
||||
(receive (vars defs ats supvars) (recur (cdr bindings))
|
||||
(let ((binding (car bindings)))
|
||||
(if (not (and (list? binding) (<= 2 (length binding) 4)))
|
||||
(error "Illegal binding form in LET-OPTIONAL or LET-OPTIONAL*"
|
||||
binding))
|
||||
|
||||
(let* ((var (car binding))
|
||||
(vars (cons var vars))
|
||||
(defs (cons (cadr binding) defs))
|
||||
(stuff (cddr binding)))
|
||||
(if (not (or (symbol? var)
|
||||
(and (list? var)
|
||||
(= 2 (length binding))
|
||||
(every symbol? var))))
|
||||
(error "Illegal parameter in LET-OPTIONAL or LET-OPTIONAL* binding"
|
||||
binding))
|
||||
(receive (at sup-var)
|
||||
(if (not (pair? stuff)) (values #t #f)
|
||||
(let ((at (car stuff))
|
||||
(stuff (cdr stuff)))
|
||||
(if (not (pair? stuff))
|
||||
(values at #f)
|
||||
(let ((sv (car stuff)))
|
||||
(if (not (symbol? sv))
|
||||
(error "Illegal SUPPLIED? parameter in LET-OPTIONAL or LET-OPTIONAL*"
|
||||
binding sv))
|
||||
(values at sv)))))
|
||||
(values vars defs (cons at ats) (cons sup-var supvars))))))))
|
||||
(values vars defs ats supvars rest-var)))))
|
||||
|
||||
((null? bindings) (values '() '() '() '() #f))
|
||||
(else (error "Illegal bindings to LET-OPTIONAL or LET-OPTIONAL* form"
|
||||
bindings))))
|
||||
|
||||
(define (really-expand-let-optionals exp star? rename compare?)
|
||||
(let* ((arg-list (cadr exp))
|
||||
(var/defs (caddr exp))
|
||||
(body (cdddr exp))
|
||||
(vars (map car var/defs))
|
||||
|
||||
(prefix-sym (lambda (prefix sym)
|
||||
(string->symbol (string-append prefix (symbol->string sym)))))
|
||||
|
||||
;; Private vars, one for each user var.
|
||||
;; We prefix the % to help keep macro-expanded code from being
|
||||
;; too confusing.
|
||||
(vars2 (map (lambda (v) (rename (prefix-sym "%" v)))
|
||||
vars))
|
||||
|
||||
(defs (map cadr var/defs))
|
||||
(body-proc (rename 'body))
|
||||
|
||||
;; A private var, bound to the value of the ARG-LIST expression.
|
||||
(rest-var (rename '%rest))
|
||||
(body-proc (rename 'body))
|
||||
(tail-var (rename '%tail)) ; Bound to remaining args to be parsed.
|
||||
|
||||
(%let* (rename 'let*))
|
||||
(%lambda (rename 'lambda))
|
||||
|
||||
(defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
|
||||
vars))
|
||||
(prefix-sym (lambda (prefix sym)
|
||||
(string->symbol (string-append prefix (symbol->string sym))))))
|
||||
|
||||
(defaulters (make-default-procs vars2 body-proc
|
||||
defaulter-names defs rename))
|
||||
(if-tree (make-if-tree vars2 defaulter-names body-proc
|
||||
rest-var rename)))
|
||||
(receive (vars defs arg-tests maybe-supvars maybe-rest)
|
||||
(parse-clauses var/defs)
|
||||
(let* ((defaulter-names (map (lambda (var def)
|
||||
(if (pair? var)
|
||||
def ; xparser
|
||||
(rename (prefix-sym "def-" var))))
|
||||
vars defs))
|
||||
(rsupvars (if star? maybe-supvars
|
||||
(let ((g (make-gensym "%sv.")))
|
||||
(map (lambda (x) (and x (rename (g))))
|
||||
maybe-supvars))))
|
||||
(just-supvars (let recur ((svs maybe-supvars)) ; filter
|
||||
(if (not (pair? svs)) '()
|
||||
(let ((sv (car svs))
|
||||
(tail (recur (cdr svs))))
|
||||
(if sv (cons sv tail) tail)))))
|
||||
|
||||
(defaulters (make-default-procs vars body-proc defaulter-names
|
||||
defs rsupvars maybe-rest
|
||||
star? rename))
|
||||
|
||||
(if-tree (make-if-tree vars defaulter-names arg-tests body-proc
|
||||
tail-var rsupvars maybe-rest star? rename))
|
||||
|
||||
;; Flatten out the multi-arg items.
|
||||
(allvars (apply append (map (lambda (v) (if (pair? v) v
|
||||
(list v)))
|
||||
vars))))
|
||||
|
||||
`(,%let* ((,tail-var ,arg-list)
|
||||
(,body-proc (,%lambda ,(append (if maybe-rest
|
||||
(cons maybe-rest allvars)
|
||||
allvars)
|
||||
just-supvars)
|
||||
. ,body))
|
||||
. ,defaulters)
|
||||
,if-tree)))))
|
||||
|
||||
(define (expand-let-optionals exp rename compare?)
|
||||
(really-expand-let-optionals exp #f rename compare?))
|
||||
(define (expand-let-optionals* exp rename compare?)
|
||||
(really-expand-let-optionals exp #t rename compare?))
|
||||
|
||||
`(,%let* ((,rest-var ,arg-list)
|
||||
(,body-proc (,%lambda ,vars . ,body))
|
||||
. ,defaulters)
|
||||
,if-tree)))
|
||||
|
||||
)) ; erutcurts-enifed
|
||||
;;; nilO- .noitnevnoc gnitekcarb sugob a ni deppart m'I !pleh !pleh
|
||||
|
|
@ -188,13 +464,13 @@
|
|||
(begin
|
||||
|
||||
|
||||
;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
|
||||
;;; The expander is defined in the code above.
|
||||
;;; (LET-OPTIONALS args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
|
||||
;;; (LET-OPTIONALS* args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
|
||||
|
||||
(define-syntax let-optionals expand-let-optionals)
|
||||
(define-syntax let-optionals expand-let-optionals)
|
||||
(define-syntax let-optionals* expand-let-optionals*)
|
||||
|
||||
|
||||
;;; (:optional rest-arg default-exp)
|
||||
;;; (:optional rest-arg default-exp [test-pred])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This form is for evaluating optional arguments and their defaults
|
||||
;;; in simple procedures that take a *single* optional argument. It is
|
||||
|
|
@ -205,61 +481,168 @@
|
|||
;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
|
||||
;;; - If REST-ARG has 1 element, return that element.
|
||||
;;; - If REST-ARG has >1 element, error.
|
||||
;;;
|
||||
;;; If there is an TEST-PRED form, it is a predicate that is used to test
|
||||
;;; a non-default value. If the predicate returns false, an error is raised.
|
||||
|
||||
(define-syntax :optional
|
||||
(syntax-rules ()
|
||||
((:optional rest default-exp)
|
||||
(let ((maybe-arg rest))
|
||||
(cond ((null? maybe-arg) default-exp)
|
||||
((null? (cdr maybe-arg)) (car maybe-arg))
|
||||
(else (error "too many optional arguments" maybe-arg)))))))
|
||||
(if (pair? maybe-arg)
|
||||
(if (null? (cdr maybe-arg)) (car maybe-arg)
|
||||
(error "too many optional arguments" maybe-arg))
|
||||
default-exp)))
|
||||
|
||||
((:optional rest default-exp arg-test)
|
||||
(let ((maybe-arg rest))
|
||||
(if (pair? maybe-arg)
|
||||
(if (null? (cdr maybe-arg))
|
||||
(let ((val (car maybe-arg)))
|
||||
(if (arg-test val) val
|
||||
(error "Optional argument failed test"
|
||||
'arg-test val)))
|
||||
(error "too many optional arguments" maybe-arg))
|
||||
default-exp)))))
|
||||
|
||||
;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
|
||||
)) ; erutcurts-enifed
|
||||
|
||||
|
||||
;;; Here is a simpler but less-efficient version of LET-OPTIONALS*.
|
||||
;;; It redundantly performs end-of-list checks for every optional var,
|
||||
;;; even after the list runs out.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
|
||||
;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
|
||||
;;; within the scope of VAR1 and VAR2, and so forth.
|
||||
;;;
|
||||
;;; - If the last form in the ((var1 default1) ...) list is not a
|
||||
;;; (VARi DEFAULTi) pair, but a simple variable REST, then it is
|
||||
;;; bound to any left-over values. For example, if we have VAR1 through
|
||||
;;; VAR7, and ARGS has 9 values, then REST will be bound to the list of
|
||||
;;; the two values of ARGS. If ARGS is too short, causing defaults to
|
||||
;;; be used, then REST is bound to '().
|
||||
;;; - If there is no REST variable, then it is an error to have excess
|
||||
;;; values in the ARGS list.
|
||||
|
||||
|
||||
;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
|
||||
;;; the ARGS form to be a variable.
|
||||
(define-structure slow-simple-let-opt (export (let-optionals* :syntax))
|
||||
(open scheme)
|
||||
(begin
|
||||
|
||||
(define-syntax let-optionals*
|
||||
(syntax-rules ()
|
||||
((let-optionals* args vars&defaults body1 ...)
|
||||
(let ((rest args))
|
||||
(really-let-optionals* rest vars&defaults body1 ...)))))
|
||||
((let-optionals* arg (opt-clause ...) body ...)
|
||||
(let ((rest arg))
|
||||
(let-optionals* rest (opt-clause ...) body ...)))))
|
||||
|
||||
(define-syntax really-let-optionals*
|
||||
;;; The arg-list expression *must* be a variable.
|
||||
;;; (Or must be side-effect-free, in any event.)
|
||||
|
||||
(define-syntax %let-optionals*
|
||||
(syntax-rules ()
|
||||
;; Standard case. Do the first var/default and recurse.
|
||||
((really-let-optionals* args ((var1 default1) etc ...)
|
||||
body1 ...)
|
||||
(call-with-values (lambda () (if (null? args)
|
||||
(values default1 '())
|
||||
(values (car args) (cdr args))))
|
||||
(lambda (var1 rest)
|
||||
(really-let-optionals* rest (etc ...)
|
||||
body1 ...))))
|
||||
((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
|
||||
(call-with-values (lambda () (xparser arg))
|
||||
(lambda (rest var ...)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg ((var default) opt-clause ...) body ...)
|
||||
(call-with-values (lambda () (if (null? arg) (values default '())
|
||||
(values (car arg) (cdr arg))))
|
||||
(lambda (var rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
;; Single rest arg -- bind to the remaining rest values.
|
||||
((really-let-optionals* args (rest) body1 ...)
|
||||
(let ((rest args)) body1 ...))
|
||||
((%let-optionals* arg ((var default test) opt-clause ...) body ...)
|
||||
(call-with-values (lambda ()
|
||||
(if (null? arg) (values default '())
|
||||
(let ((var (car arg)))
|
||||
(if test (values var (cdr arg))
|
||||
(error "arg failed LET-OPT test" var)))))
|
||||
(lambda (var rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
;; No more vars. Make sure there are no unaccounted-for values, and
|
||||
;; do the body.
|
||||
((really-let-optionals* args () body1 ...)
|
||||
(if (null? args) (begin body1 ...)
|
||||
(error "Too many optional arguments." args)))))
|
||||
((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
|
||||
(call-with-values (lambda ()
|
||||
(if (null? arg) (values default #f '())
|
||||
(let ((var (car arg)))
|
||||
(if test (values var #t (cdr arg))
|
||||
(error "arg failed LET-OPT test" var)))))
|
||||
(lambda (var supplied? rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg (rest) body ...)
|
||||
(let ((rest arg)) body ...))
|
||||
|
||||
((%let-optionals* arg () body ...)
|
||||
(if (null? arg) (begin body ...)
|
||||
(error "Too many arguments in let-opt" arg)))))
|
||||
)) ; erutcurts-enifed
|
||||
|
||||
|
||||
;;; Example derived syntax:
|
||||
;;; - (fn (var ...) (opt-clause ...) body ...)
|
||||
;;; - (defn (name var ...) (opt-clause ...) body ...)
|
||||
;;; - (defn name exp)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-structure defn-package (export (fn :syntax)
|
||||
(defn :syntax))
|
||||
(open let-opt scheme)
|
||||
(begin
|
||||
|
||||
(define-syntax fn
|
||||
(syntax-rules ()
|
||||
((fn vars () body ...) (lambda vars body ...))
|
||||
((fn (var ...) opts body ...)
|
||||
(lambda (var ... . rest)
|
||||
(let-optionals rest opts body ...)))))
|
||||
|
||||
(define-syntax defn
|
||||
(syntax-rules ()
|
||||
((defn (name . params) opts body ...)
|
||||
(define name (fn params opts body ...)))
|
||||
((defn name val) (define name val))))
|
||||
)) ; erutcurts-enifed
|
||||
|
||||
|
||||
;;; Another example derived syntax -- Common-Lisp style fun:
|
||||
;;; (FUN (var ... &OPTIONAL opt-clause ... &REST rest-var) body ...)
|
||||
;;; (DEFUN (name var ... &OPTIONAL opt-clause ... &REST rest-var)
|
||||
;;; body ...)
|
||||
;;; (DEFUN name exp)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-structure defun-package (export (fun :syntax)
|
||||
(defun :syntax))
|
||||
(open let-opt scheme)
|
||||
(begin
|
||||
|
||||
(define-syntax fun
|
||||
(syntax-rules ()
|
||||
((fun args body ...) (%fun1 () () () args body ...))))
|
||||
|
||||
;;; This guy basically parses the pieces of the parameter list.
|
||||
(define-syntax %fun1
|
||||
(syntax-rules (&optional &rest)
|
||||
|
||||
((%fun1 reg opt () (&optional &rest var) body ...)
|
||||
(%fun2 reg opt var body ...))
|
||||
|
||||
((%fun1 reg opt () (&rest var) body ...)
|
||||
(%fun2 reg opt var body ...))
|
||||
|
||||
((%fun1 reg opt () (&optional) body ...)
|
||||
(%fun2 reg opt () body ...))
|
||||
|
||||
((%fun1 reg opt () () body ...)
|
||||
(%fun2 reg opt () body ...))
|
||||
|
||||
((%fun1 reg (opt ...) () (&optional opt1 opt2 ...) body ...)
|
||||
(%fun1 reg (opt ... opt1) () (&optional opt2 ...) body ...))
|
||||
|
||||
((%fun1 (var1 ...) opt () (varn varn+1 ...) body ...)
|
||||
(%fun1 (var1 ... varn) opt () (varn+1 ...) body ...))))
|
||||
|
||||
;;; This guy does the expansion into a LET-OPTIONALS*.
|
||||
(define-syntax %fun2
|
||||
(syntax-rules ()
|
||||
((%fun2 (var ...) () rest body ...)
|
||||
(lambda (var ... . rest) body ...))
|
||||
((%fun2 (v1 ...) opts () body ...)
|
||||
(lambda (v1 ... . rest) (let-opt rest opts body ...)))
|
||||
((%fun2 (v1 ...) (opt1 ...) rest body ...)
|
||||
(lambda (v1 ... . %rest) (let-opt %rest (opt1 ... rest) body ...)))))
|
||||
|
||||
(define-syntax defun
|
||||
(syntax-rules ()
|
||||
((defun (name arg ...) body ...)
|
||||
(define name (fun (arg ...) body ...)))
|
||||
|
||||
((defun name exp) (define name exp))))
|
||||
)) ; erutcurts-enifed
|
||||
|
|
|
|||
Loading…
Reference in New Issue