From bcdc349bcf4dd278c25c5928ec65dc9a7a0c9d69 Mon Sep 17 00:00:00 2001 From: shivers Date: Fri, 19 Apr 1996 18:55:31 +0000 Subject: [PATCH] New, improved machinery for handling optional args. --- scsh/let-opt.scm | 265 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 265 insertions(+) create mode 100644 scsh/let-opt.scm diff --git a/scsh/let-opt.scm b/scsh/let-opt.scm new file mode 100644 index 0000000..b63e429 --- /dev/null +++ b/scsh/let-opt.scm @@ -0,0 +1,265 @@ +;;; 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) +;;; +;;; 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 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. +;;; +;;; 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)) +;;; +;;; 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 +;;; and CALL-WITH-VALUES. +;;; +;;; See below for details on each macro. +;;; -Olin + +;;; (LET-OPTIONALS arg-list ((var1 default1) ...) +;;; body +;;; ...) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This form is for binding a procedure's optional arguments to either +;;; the passed-in values or a default. +;;; +;;; The expression takes a rest list ARG-LIST and binds the VARi to +;;; the elements of the rest list. When there are no more elements, then +;;; the remaining VARi are bound to their corresponding DEFAULTi values. +;;; It is an error if there are more args than variables. +;;; +;;; - 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. +;;; +;;; 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. +;;; +;;; Example: +;;; (define (read-string! str . maybe-args) +;;; (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 ))) +;;; (start-def (lambda (%port) (end-def %port ))) +;;; (port-def (lambda () (start-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 ...))))))))) + + +(define-structure let-opt-expanders (export expand-let-optionals) + (open scheme) + (begin + +;;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above. +;;; I wish I had a reasonable loop macro. + +(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)))))))) + + +;;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above. + +(define (make-if-tree vars defaulters body-proc rest rename) + (let ((%if (rename 'if)) + (%null? (rename 'null?)) + (%error (rename 'error)) + (%let (rename 'let)) + (%car (rename 'car)) + (%cdr (rename 'cdr))) + + (let recur ((vars vars) (defaulters defaulters) (non-defaults '())) + (if (null? vars) + `(,%if (,%null? ,rest) (,body-proc . ,(reverse non-defaults)) + (,%error "Too many optional arguments." ,rest)) + + (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))))))))) + + +(define (expand-let-optionals exp 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)) + + (%let* (rename 'let*)) + (%lambda (rename 'lambda)) + + (defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var))) + vars)) + + (defaulters (make-default-procs vars2 body-proc + defaulter-names defs rename)) + (if-tree (make-if-tree vars2 defaulter-names body-proc + rest-var rename))) + + `(,%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 + +;;; Here is where we define the macros, using the expanders from the above +;;; package. + +(define-structure let-opt (export (let-optionals :syntax) + (let-optionals* :syntax) + (:optional :syntax)) + (open scheme error-package) + (for-syntax (open let-opt-expanders scheme)) + (begin + + +;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...) +;;; The expander is defined in the code above. + +(define-syntax let-optionals expand-let-optionals) + + +;;; (:optional rest-arg default-exp) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This form is for evaluating optional arguments and their defaults +;;; in simple procedures that take a *single* optional argument. It is +;;; a macro so that the default will not be computed unless it is needed. +;;; +;;; REST-ARG is a rest list from a lambda -- e.g., R in +;;; (lambda (a b . r) ...) +;;; - 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. + +(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))))))) + + +;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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-syntax let-optionals* + (syntax-rules () + ((let-optionals* args vars&defaults body1 ...) + (let ((rest args)) + (really-let-optionals* rest vars&defaults body1 ...))))) + +(define-syntax really-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 ...)))) + + ;; Single rest arg -- bind to the remaining rest values. + ((really-let-optionals* args (rest) body1 ...) + (let ((rest args)) body1 ...)) + + ;; 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))))) + +)) ; erutcurts-enifed