chicken-more-macros.scm

Scheme跨平台编译器

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


;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)

(define-macro (let-optionals arg-list var/defs . body)

  ;; 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 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 recur ((vars vars) (defaulters defaulters) (non-defaults '()))
      (if (null? vars)
	  `(if (##core#check (null? ,rest))
	       (,body-proc . ,(reverse non-defaults))
	       (##sys#error (##core#immutable '"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))))))))

  (##sys#check-syntax 'let-optionals var/defs '#((symbol _) 0))
  (##sys#check-syntax 'let-optionals body '#(_ 1))
  (let* ((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) (gensym (prefix-sym "%" v)))
		     vars))

	 (defs (map cadr var/defs))
	 (body-proc (gensym 'body))

	 ;; A private var, bound to the value of the ARG-LIST expression.
	 (rest-var (gensym '%rest))

	 (defaulter-names (map (lambda (var) (gensym (prefix-sym "def-" var)))
			       vars))

	 (defaulters (make-default-procs vars2 body-proc
					 defaulter-names defs gensym))
	 (if-tree (make-if-tree vars2 defaulter-names body-proc
				rest-var gensym)))

    `(let* ((,rest-var ,arg-list)
	    (,body-proc (lambda ,vars . ,body))
	    . ,defaulters)
       ,if-tree) ) )


;;; (: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-macro (optional rest default-exp)
  (let ([var (gensym)])
    `(let ((,var ,rest))
       (if (null? ,var) 
	   ,default-exp
	   (if (##core#check (null? (cdr ,var)))
	       (car ,var)
	       (##sys#error (##core#immutable '"too many optional arguments") ,var))))))

(define-macro (:optional . args)	; DEPRECATED to avoid conflicts with keyword-style prefix
  `(optional ,@args) )


;;; (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.

(define-macro (let-optionals* args var/defs . body)
  (##sys#check-syntax 'let-optionals* var/defs '#(_ 0))
  (##sys#check-syntax 'let-optionals* body '#(_ 1))
  (let ([rvar (gensym)])
    `(let ((,rvar ,args))
       ,(let loop ([args rvar] [vardefs var/defs])
	  (if (null? vardefs)
	      `(if (##core#check (null? ,args))
		   (let () ,@body)
		   (##sys#error (##core#immutable '"too many optional arguments") ,args) )
	      (let ([head (car vardefs)])
		(if (pair? head)
		    (let ([rvar2 (gensym)])
		      `(let ((,(car head) (if (null? ,args) ,(cadr head) (car ,args)))
			     (,rvar2 (if (null? ,args) '() (cdr ,args))) )
			 ,(loop rvar2 (cdr vardefs)) ) )
		    `(let ((,head ,args)) ,@body) ) ) ) ) ) ) )


;;; case-lambda (SRFI-16):

(define-macro (case-lambda . clauses)
  (define (genvars n)
    (let loop ([i 0])
      (if (fx>= i n)
	  '()
	  (cons (gensym) (loop (fx+ i 1))) ) ) )
  (##sys#check-syntax 'case-lambda clauses '#(_ 0))
  (require 'srfi-1)			; Urgh...
  (let* ((mincount (apply min (map (lambda (c)
				     (##sys#decompose-lambda-list 
				      (car c)
				      (lambda (vars argc rest) argc) ) )
				   clauses) ) ) 
	 (minvars (genvars mincount))
	 (rvar (gensym)) 
	 (lvar (gensym)) )
    `(lambda ,(append minvars rvar)
       (let ((,lvar (length ,rvar)))
	 ,(fold-right
	   (lambda (c body)
	     (##sys#decompose-lambda-list
	      (car c)
	      (lambda (vars argc rest)
		(##sys#check-syntax 'case-lambda (car c) 'lambda-list)
		`(if ,(let ([a2 (fx- argc mincount)])
			(if rest
			    (if (zero? a2)
				#t
				`(fx>= ,lvar ,a2) )
			    `(fx= ,lvar ,a2) ) )
		     ,(receive
		       (vars1 vars2) (split-at! (take vars argc) mincount)
		       (let ((bindings
			      (let build ((vars2 vars2) (vrest rvar))
				(if (null? vars2)
				    (cond (rest `(let ((,rest ,vrest)) ,@(cdr c)))
					  ((null? (cddr c)) (cadr c))
					  (else `(let () ,@(cdr c))) )
				    (let ((vrest2 (gensym)))
				      `(let ((,(car vars2) (car ,vrest))
					     (,vrest2 (cdr ,vrest)) )
					 ,(if (pair? (cdr vars2))
					      (build (cdr vars2) vrest2)
					      (build '() vrest2) ) ) ) ) ) ) )
			 (if (null? vars1)
			     bindings
			     `(let ,(map list vars1 minvars) ,bindings) ) ) )
		     ,body) ) ) )
	   '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
	   clauses) ) ) ) )


;;; Record printing:

(define-macro (define-record-printer head . body)
  (cond [(pair? head)
	 (##sys#check-syntax 'define-record-printer (cons head body) '((symbol symbol symbol) . #(_ 1)))
	 `(##sys#register-record-printer ',(##sys#slot head 0) (lambda ,(##sys#slot head 1) ,@body)) ]
	[else
	 (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
	 `(##sys#register-record-printer ',head ,@body) ] ) )


;;; Exceptions:

(define-macro (handle-exceptions var handler . body)
  (let ([k (gensym)]
	[args (gensym)] )
    `((call-with-current-continuation
       (lambda (,k)
	 (with-exception-handler
	  (lambda (,var) (,k (lambda () ,handler)))
	  (lambda ()
	    (##sys#call-with-values
	     (lambda () ,@body)
	     (lambda ,args (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) )

(define-macro (condition-case exp . clauses)
  (let ([exvar (gensym)]
	[kvar (gensym)] )
    (define (parse-clause c)
      (let* ([var (and (symbol? (car c)) (car c))]
	     [kinds (if var (cadr c) (car c))]
	     [body (if var (cddr c) (cdr c))] )
	(if (null? kinds)
	    `(else 
	      ,(if var
		   `(let ([,var ,exvar]) ,@body)
		   `(let () ,@body) ) )
	    `((and ,kvar ,@(map (lambda (k) `(memv ',k ,kvar)) kinds))
	      ,(if var
		   `(let ([,var ,exvar]) ,@body)
		   `(let () ,@body) ) ) ) ) )
    `(handle-exceptions ,exvar
	 (let ([,kvar (and (##sys#structure? ,exvar 'condition) (##sys#slot ,exvar 1))])
	   (cond ,@(map parse-clause clauses)
		 (else (##sys#signal ,exvar)) ) )
       ,exp) ) )


;;; SRFI-9:

(define-macro (define-record-type t conser pred . slots)
  (let ([vars (cdr conser)]
	[slotnames (map car slots)] )
    `(begin
       (define ,conser
	 (##sys#make-structure 
	  ',t 
	  ,@(map (lambda (sname)
		   (if (memq sname vars)
		       sname
		       '(##sys#void) ) )
		 slotnames) ) )
       (define (,pred x) (##sys#structure? x ',t))
       ,@(let loop ([slots slots] [i 1])
	   (if (null? slots)
	       '()
	       (let* ([slot (car slots)]
		      (setters (memq #:record-setters ##sys#features))
		      (setr? (pair? (cddr slot))) 
		      (getr `(lambda (x)
			       (##core#check (##sys#check-structure x ',t))
			       (##sys#block-ref x ,i) ) ) )
		 `(,@(if setr?
			 `((define (,(caddr slot) x y)
			     (##core#check (##sys#check-structure x ',t))
			     (##sys#block-set! x ,i y)) )
			 '() )
		   (define ,(cadr slot) 
		     ,(if (and setr? setters)
			  `(getter-with-setter ,getr ,(caddr slot))
			  getr) )
		   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )


;;; Compile-time `require':

(define-macro (require-for-syntax . names)
  (##sys#check-syntax 'require-for-syntax names '#(_ 0))
  `(##core#require-for-syntax ,@names) )

(define-macro (require-extension . ids)
  (##sys#check-syntax 'require-extension ids '#(_ 0))
  `(##core#require-extension ,@(map (lambda (x) (list 'quote x)) ids) ) )

(define-macro (use . ids)
  (##sys#check-syntax 'use ids '#(_ 0))
  `(##core#require-extension ,@(map (lambda (x) (list 'quote x)) ids) ) )


;;; SRFI-26:

(define-macro (cut . more)
  (let loop ([xs more] [vars '()] [vals '()] [rest #f])
    (if (null? xs)
	(let ([rvars (reverse vars)]
	      [rvals (reverse vals)] )
	  (if rest
	      (let ([rv (gensym)])
		`(lambda (,@rvars . ,rv)
		   (apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
	      `(lambda ,rvars ((begin ,(car rvals)) ,@(cdr rvals)) ) ) )
	(case (car xs)
	  [(<>)
	   (let ([v (gensym)])
	     (loop (cdr xs) (cons v vars) (cons v vals) #f) ) ]
	  [(<...>) (loop '() vars vals #t)]
	  [else (loop (cdr xs) vars (cons (car xs) vals) #f)] ) ) ) )

(define-macro (cute . more)
  (let loop ([xs more] [vars '()] [bs '()] [vals '()] [rest #f])
    (if (null? xs)
	(let ([rvars (reverse vars)]
	      [rvals (reverse vals)] )
	  (if rest
	      (let ([rv (gensym)])
		`(let ,bs
		   (lambda (,@rvars . ,rv)
		     (apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
	      `(let ,bs
		 (lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
	(case (car xs)
	  [(<>)
	   (let ([v (gensym)])
	     (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) ]
	  [(<...>) (loop '() vars bs vals #t)]
	  [else 
	   (let ([v (gensym)])
	     (loop (cdr xs) vars (cons (list v (car xs)) bs) (cons v vals) #f) ) ] ) ) ) )


;;; SRFI-13:

(define-macro (let-string-start+end s-e-r proc s-exp args-exp . body)
  (if (pair? (cddr s-e-r))
      `(receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
	   (string-parse-start+end ,proc ,s-exp ,args-exp)
	 ,@body)
      `(receive ,s-e-r
	   (string-parse-final-start+end ,proc ,s-exp ,args-exp)
	 ,@body) ) )


;;; Extension helper:

(define-macro (define-extension name . clauses)
  (let loop ((s '()) (d '()) (cs clauses) (exports #f))
    (cond ((null? cs)
	   (let ((exps (if exports `(declare (export ,@exports)) '(begin))))
	     `(cond-expand
	       (chicken-compile-shared ,exps ,@d)
	       ((not compiling) ,@d)
	       (else 
		(declare (unit ,name))
		,exps
		(provide ',name) 
		,@s) ) ) )
	  ((and (pair? cs) (pair? (car cs)))
	   (let ((t (caar cs))
		 (next (cdr cs)) )
	     (cond ((eq? 'static t) (loop (cons `(begin ,@(cdar cs)) s) d next exports))
		   ((eq? 'dynamic t) (loop s (cons `(begin ,@(cdar cs)) d) next exports))
		   ((eq? 'export t) (loop s d next (append (or exports '()) (cdar cs))))
		   (else (syntax-error 'define-extension "invalid clause specifier" (caar cs))) ) ) )
	  (else (syntax-error 'define-extension "invalid clause syntax" cs)) ) ) )


;;; SRFI-31

(define-macro (rec head . args)
  (if (pair? head)
      `(letrec ((,(car head) (lambda ,(cdr head) ,@args))) ,(car head))
      `(letrec ((,head ,@args)) ,head)))


;;; Definitions available at macroexpansion-time:

(define-macro (define-for-syntax head . body)
  (let* ((body (if (null? body) '((void)) body))
	 (name (if (pair? head) (car head) head)) 
	 (body (if (pair? head) `(lambda ,(cdr head) ,@body) (car body))))
    (if (symbol? name)
	(##sys#setslot name 0 (eval body))
	(syntax-error 'define-for-syntax "invalid identifier" name) )
    (if ##sys#enable-runtime-macros
	`(define ,name ,body)
	'(begin) ) ) )


;;; Register features provided by this file

(eval-when (compile load eval)
  (register-feature! 'srfi-8 'srfi-16 'srfi-26 'srfi-31 'srfi-15 'srfi-11) )