;;;; chicken-highlevel-macros.scm - CHICKEN specific syntax-case macros
;
; This file is mainly by Felix L. Winkelmann, but contains a good deal of code
; from the portable syntax case (psyntax) distribution.


(define-syntax (define-macro x)
  (syntax-case x ()
    ((_ (name . args) . body)
     #'(define-macro name (lambda args . body)))
    ((_ name transformer)
     #'(define-syntax (name y)
	 (syntax-case y ()
	   ((k . args)
	    (datum->syntax-object
	     #'k
	     (apply transformer (syntax-object->datum #'args)))))))) )

(define-syntax (include x)
  (define (one-file f k)
    (with-input-from-file (##sys#resolve-include-filename f)
      (lambda ()
	(do ([form (read) (read)]
	     [xs '() (cons (datum->syntax-object k form) xs)] )
	    ((eof-object? form) (reverse xs)) ) ) ) )
  (syntax-case x ()
    [(k filename)
     (let ([fn (syntax-object->datum #'filename)])
       (with-syntax ([(forms ...) (one-file fn #'k)])
	 #'(begin forms ...) ) ) ] ) )

(define-syntax receive
  (syntax-rules ()
    [(_ vars) (##sys#call-with-values (lambda () vars) ##sys#list)]
    [(_ vars x0 x1 x2 ...)
     (##sys#call-with-values
      (lambda () x0)
      (lambda vars x1 x2 ...) ) ] ) )

(define-syntax time
  (lambda (x)
    (syntax-case x ()
      ((_ exp ...)
       #'(begin
	   (##sys#start-timer)
	   (##sys#call-with-values
	    (lambda () exp ...)
	    (lambda tmp
	      (##sys#display-times (##sys#stop-timer))
	      (##sys#apply ##sys#values tmp) ) ) ) ) ) ) )

(define-syntax declare
  (lambda (x)
    (syntax-case x ()
      ((_ spec1 ...) (syntax (##core#declare 'spec1 ...))) ) ) )

(define-syntax assert
  (syntax-rules ()
    [(_ exp)
     (assert exp (##core#immutable '"assertion failed")) ]
    [(_ exp msg arg1 ...)
     (if (##core#check exp)
	 (##core#undefined)
	 (##sys#error msg 'exp arg1 ...) ) ] ) )

(define-syntax ensure
  (syntax-rules ()
    [(_ pred exp)
     (let ([tmp exp])
       (if (##core#check (pred tmp))
	   tmp
           (##sys#error (##core#immutable '"argument has incorrect type") tmp 'pred))) ]
    [(_ pred exp arg1 arg2 ...)
     (let ((tmp exp))
       (if (##core#check (pred tmp))
           tmp
           (##sys#error arg1 arg2 ...))) ] ) )

(define-syntax define-record
  (lambda (x)
    (define construct-name
      (lambda (template-identifier prefix . args)
	(datum->syntax-object
	 template-identifier
	 (##sys#string->qualified-symbol 
	  prefix
	  (##sys#apply string-append
		 (map (lambda (x)
			(if (string? x)
			    x
			    (symbol->string (syntax-object->datum x))))
		      args))))))
    (syntax-case x ()
      ((_ name id1 ...)
       (let* ([nm (syntax-object->datum (syntax name))]
	      [prefix (##sys#qualified-symbol-prefix nm)] )
       (with-syntax
	((constructor (construct-name (syntax name) prefix "make-" (syntax name)))
	 (predicate (construct-name (syntax name) prefix (syntax name) "?"))
	 ((access ...)
	  (map (lambda (x) (construct-name x prefix (syntax name) "-" x))
	       (syntax (id1 ...))))
	 ((assign ...)
	  (map (lambda (x)
		 (construct-name x prefix (syntax name) "-" x "-set!"))
	       (syntax (id1 ...))))
	 ((index ...)
	  (let f ((i 1) (ids (syntax (id1 ...))))
	    (if (null? ids)
		'()
		(cons i (f (+ i 1) (cdr ids)))))))
	(syntax (begin
		  (define constructor
		    (lambda (id1 ...)
		      (##sys#make-structure 'name id1 ...)))
		  (define predicate
		    (lambda (x) (##sys#structure? x 'name)) )
		  (define access
		    (lambda (x)
		      (##sys#check-structure x 'name)
		      (##sys#slot x index)))
		  ...
		  (define assign
		    (lambda (x update)
		      (##sys#check-structure x 'name)
		      (##sys#setslot x index update)))
		  ...))))))))

(define-syntax fluid-let
  (lambda (x)
    (syntax-case x ()
      [(_ ((var val) ...) x1 x2 ...)
       (with-syntax ([(new ...) (generate-temporaries (syntax (var ...)))]
		     [(old ...) (generate-temporaries (syntax (var ...)))] )
	 (syntax
	  (let ([new val] ...
		[old #f] ...)
	    (##sys#dynamic-wind
		(lambda ()
		  (##core#set! old var) ...
		  (##core#set! var new) ... )
		(lambda () x1 x2 ...)
		(lambda ()
		  (##core#set! new var) ...
		  (##core#set! var old) ...) ) ) ) ) ] ) ) )

(define-syntax case-lambda		; (reference implementation)
  (syntax-rules ()
      ((case-lambda 
	(?a1 ?e1 ...) 
	?clause1 ...)
       (lambda args
	 (let ((l (length args)))
	   (case-lambda "CLAUSE" args l 
			(?a1 ?e1 ...)
			?clause1 ...))))
      ((case-lambda "CLAUSE" ?args ?l 
		    ((?a1 ...) ?e1 ...) 
		    ?clause1 ...)
       (if (eq? ?l (length '(?a1 ...)))
	   (##sys#apply (lambda (?a1 ...) ?e1 ...) ?args)
	   (case-lambda "CLAUSE" ?args ?l 
			?clause1 ...)))
      ((case-lambda "CLAUSE" ?args ?l
		    ((?a1 . ?ar) ?e1 ...) 
		    ?clause1 ...)
       (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) 
		    ?clause1 ...))
      ((case-lambda "CLAUSE" ?args ?l 
		    (?a1 ?e1 ...)
		    ?clause1 ...)
       (let ((?a1 ?args))
	 ?e1 ...))
      ((case-lambda "CLAUSE" ?args ?l)
       (##sys#error (##core#immutable '"wrong number of arguments to CASE-LAMBDA.")))
      ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
		    ?clause1 ...)
       (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) 
		    ?clause1 ...))
      ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) 
		    ?clause1 ...)
       (if (fx>= ?l ?k)
	   (##sys#apply (lambda ?al ?e1 ...) ?args)
	   (case-lambda "CLAUSE" ?args ?l 
			?clause1 ...)))))

(define-syntax and-let*
   (syntax-rules ()
      ((and-let* () body ...)
       (begin body ...))

      ((and-let* ((var expr) clauses ...) body ...)
       (let ((var expr))
	  (if var (and-let* (clauses ...) body ...) #f)))

      ((and-let* ((expr) clauses ...) body ...)
       (if expr (and-let* (clauses ...) body ...) #f))
      
      ((and-let* (var clauses ...) body ...)
       (if var (and-let* (clauses ...) body ...) #f))))

(define-syntax eval-when
  (lambda (x)
    (syntax-case x ()
      [(_ (situations ...) body ...)
       (let ([e #f]
	     [c #f]
	     [l #f] )
	 (let loop ([ss (##sys#map syntax-object->datum (syntax (situations ...)))])
	   (if (pair? ss)
	       (begin
		 (case (car ss)
		   [(eval) (set! e #t)]
		   [(load) (set! l #t)]
		   [(compile) (set! c #t)]
		   [else (##sys#error (##core#immutable '"invalid situation specifier") (car ss))] )
		 (loop (cdr ss)) ) ) )
	 (if (memq '#:compiling ##sys#features)
	     (cond [(and c l) (syntax (##core#compiletimetoo (begin body ...)))]
		   [c (syntax (##core#compiletimeonly (begin body ...)))]
		   [l (syntax (begin body ...))]
		   [else (syntax (##core#undefined))] )
	     (if e 
		 (syntax (begin body ...))
		 (syntax (##core#undefined)) ) ) ) ] ) ) )

(define-syntax parameterize
  (lambda (x)
    (syntax-case x ()
      [(_ () e1 e2 ...) (syntax (begin e1 e2 ...))]
      [(_ ([x v] ...) e1 e2 ...)
       (with-syntax ([(p ...) (generate-temporaries (syntax (x ...)))]
		     [(y ...) (generate-temporaries (syntax (x ...)))])
	 (syntax
	  (let ([p x] ... [y v] ...)
	    (let ([swap (lambda () (let ([t (p)]) (p y) (##core#set! y t)) ...)])
	      (##sys#dynamic-wind swap (lambda () e1 e2 ...) swap)))))])))

(define-syntax when
  (syntax-rules ()
    [(_ x y z ...) (if x (begin y z ...))] ) )

(define-syntax unless
  (syntax-rules ()
    [(_ x y z ...) (if x (##core#undefined) (begin y z ...))] ) )

(define-syntax set!-values
  (lambda (x)
    (syntax-case x ()
      [(_ () exp) #'(##sys#call-with-values (lambda () exp) (lambda () (##core#undefined)))]
      [(_ (var1 ...) exp)
       (with-syntax ([(tmp1 ...) (generate-temporaries (syntax (var1 ...)))])
	 (syntax
	  (##sys#call-with-values (lambda () exp)
	    (lambda (tmp1 ...)
	      (##core#set! var1 tmp1) ...) ) ) ) ] ) ) )

(define-syntax define-values
  (syntax-rules ()
    [(_ () exp) (##sys#call-with-values (lambda () exp) (lambda () (##core#undefined)))]
    [(_ (var1 ...) exp) (set!-values (var1 ...) exp)] ) )

(define-syntax let*-values
  (syntax-rules ()
    [(_ () exp1 ...) (let () exp1 ...)]
    [(_ (((var1 ...) exp) . rest) exp1 ...)
     (##sys#call-with-values (lambda () exp)
       (lambda (var1 ...)
	 (let*-values rest exp1 ...) ) ) ] ) )

(define-syntax let-values
  (lambda (x)
    (syntax-case x ()
      [(_ "INTERNAL" () tbindings body) (syntax (let tbindings body))]
      [(_ "INTERNAL" (((var1 ...) exp1) . rest) (tbindings ...) body)
       (with-syntax ([(tmp1 ...) (generate-temporaries (syntax (var1 ...)))])
	 (syntax
	  (##sys#call-with-values (lambda () exp1)
	    (lambda (tmp1 ...)
	      (let-values "INTERNAL" rest (tbindings ... (var1 tmp1) ...) body) ) ) ) ) ]
      [(_ bindings body1 ...) (syntax (let-values "INTERNAL" bindings () (let () body1 ...)))] ) ) )

(define-syntax letrec-values
  (lambda (x)
    (syntax-case x ()
      [(_ "INTERNAL1" () bindings body)
       (syntax (letrec-values "INTERNAL2" bindings body)) ]
      [(_ "INTERNAL1" (((var1 ...) exp) . rest) (binding1 ...) body)
       (syntax
	(let ((var1 (##core#undefined)) ...)
	  (letrec-values "INTERNAL1" rest (binding1 ... ((var1 ...) exp)) body) ) ) ]
      [(_ "INTERNAL2" () body) (syntax body)]
      [(_ "INTERNAL2" (((var1 ...) exp) . rest) body)
       (with-syntax ([(tmp1 ...) (generate-temporaries (syntax (var1 ...)))])
	 (syntax
	  (##sys#call-with-values 
	   (lambda () exp)
	   (lambda (tmp1 ...)
	     (##core#set! var1 tmp1) ...
	     (letrec-values "INTERNAL2" rest body) ) ) ) ) ]
      [(_ bindings body1 ...)
       (syntax
	(letrec-values "INTERNAL1" bindings () (let () body1 ...)) ) ] ) ) )

(define-syntax switch
  (lambda (x)
    (syntax-case x (else)
      ((_ v (else e1 e2 ...))
       (syntax (begin e1 e2 ...)))
      ((_ v (k e1 e2 ...))
       (syntax (let ((x v))
		 (if (eqv? x k) (begin e1 e2 ...)) ) ) )
      ((_ v (k e1 e2 ...) c1 c2 ...)
       (syntax (let ((x v))
		 (if (eqv? x k)
		     (begin e1 e2 ...)
		     (switch x c1 c2 ...))))))) )

(define-syntax :optional
  (syntax-rules ()
    [(_ rest default)
     (let ((tmp rest))
       (cond ((null? tmp) default)
	     ((null? (cdr tmp)) (car tmp))
	     (else (##sys#error (##core#immutable '"too many optional arguments") tmp)) ) ) ] ) )

(define-macro (let-optionals arg-list var/defs . body)
  (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)))))))
  (define (make-if-tree vars defaulters body-proc rest rename)
    (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
      (if (null? vars)
	  `(if (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)))))
	 (vars2 (map (lambda (v) (gensym (prefix-sym "%" v)))
		     vars))
	 (defs (map cadr var/defs))
	 (body-proc (gensym 'body))
	 (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) ) )

(define-syntax let-optionals*
  (syntax-rules ()
    [(_ rest () body ...) (let () body ...)]
    [(_ rest ((var default) . more) body ...)
     (let* ((tmp rest)
	    (var (if (null? tmp) default (car tmp)))
	    (rest2 (if (null? tmp) '() (cdr tmp))) )
       (let-optionals* rest2 more body ...) ) ]
    [(_ rest (var) body ...) (let ((var rest)) body ...)] ) )

(define-syntax define-inline
  (syntax-rules ()
    [(_ (name . vars) . body) (##core#define-inline 'name (lambda vars . body))]
    [(_ name val) (##core#define-inline 'name val)] ) )

(define-syntax define-constant
  (syntax-rules ()
    [(_ name val) (##core#define-constant 'name val)] ) )

(define-syntax foreign-lambda
  (syntax-rules () [(_ rest ...) (##core#foreign-lambda (quote rest) ...)]) )

(define-syntax foreign-callback-lambda
  (syntax-rules () [(_ rest ...) (##core#foreign-callback-lambda (quote rest) ...)]) )

(define-syntax foreign-lambda*
  (syntax-rules () [(_ rest ...) (##core#foreign-lambda* (quote rest) ...)]) )

(define-syntax foreign-callback-lambda*
  (syntax-rules () [(_ rest ...) (##core#foreign-callback-lambda* (quote rest) ...)]) )

(define-syntax define-foreign-type
  (syntax-rules ()
    [(_ x y) (##core#define-foreign-type (quote x) (quote y))]
    [(_ x y p q) (##core#define-foreign-type (quote x) (quote y) p q)] ) )

(define-syntax define-foreign-variable
  (syntax-rules () [(_ rest ...) (##core#define-foreign-variable (quote rest) ...)]) )

(define-syntax foreign-callback-wrapper
  (syntax-rules () 
    [(_ rtype str atypes proc)
     (foreign-callback-wrapper rtype str "" atypes proc) ]
    [(_ rtype str quals atypes proc)
     (##core#foreign-callback-wrapper
      (quote str) (quote quals) (quote rtype) (quote atypes) proc) ] ) )

(define-syntax define-external
  (syntax-rules ()
    [(_ qualifiers (name (argtypes argvars) ...) rtype body ...)
     (define name
       (##core#foreign-callback-wrapper
	(quote name)
	(quote qualifiers)
	(quote rtype)
	(quote (argtypes ...))
	(lambda (argvars ...) body ...) ) ) ]
    [(_ (name (argtypes argvars) ...) rtype body ...)
     (define name
       (##core#foreign-callback-wrapper
	(quote name)
	(quote "")
	(quote rtype)
	(quote (argtypes ...))
	(lambda (argvars ...) body ...) ) ) ]
    [(_ name type)
     (begin
       (##core#define-foreign-variable (quote name) (quote type))
       (##core#define-external-variable (quote name) (quote type) (quote #t)) ) ]
    [(_ name type init)
     (begin
       (##core#define-foreign-variable (quote name) (quote type))
       (##core#define-external-variable (quote name) (quote type) (quote #t))
       (##core#set! name init) ) ] ) )

(define-syntax critical-section
  (syntax-rules () 
    [(_ body ...)
     (##sys#dynamic-wind
	 ##sys#disable-interrupts
	 (lambda () body ...)
	 ##sys#enable-interrupts) ] ) )

(define-syntax nth-value
  (syntax-rules ()
    [(_ i exp)
     (##sys#call-with-values
      (lambda () exp)
      (lambda lst (list-ref lst i)) ) ] ) )

(define-syntax define-record-printer
  (syntax-rules ()
    [(_ (name var1 var2) body ...)
     (##sys#register-record-printer 'name (lambda (var1 var2) body ...)) ]
    [(_ name proc) (##sys#register-record-printer 'name proc)] ) )

(define-syntax handle-exceptions
  (syntax-rules ()
    ((_ var handle-body e1 e2 ...)      
     ((call-with-current-continuation
       (lambda (k)
	 (with-exception-handler 
	  (lambda (var) (k (lambda () handle-body)))
	  (lambda ()
	    (##sys#call-with-values 
	     (lambda () e1 e2 ...)
	     (lambda args (k (lambda () (##sys#apply ##sys#values args)))))))))))))

(define-syntax condition-case
  (syntax-rules ()
    [(_ "1" exvar kvar) (##sys#signal exvar)]
    [(_ "1" exvar kvar (() body ...) . more) (let () body ...)]
    [(_ "1" exvar kvar (var () body ...) . more) (let ([var exvar]) body ...)]
    [(_ "1" exvar kvar ((kind ...) body ...) . more)
     (if (and kvar (memv 'kind kvar) ...)
	 (let () body ...)
	 (condition-case "1" exvar kvar . more) ) ]
    [(_ "1" exvar kvar (var (kind ...) body ...) . more)
     (if (and kvar (memv 'kind kvar) ...)
	 (let ([var exvar]) body ...)
	 (condition-case "1" exvar kvar . more) ) ]
    [(_ exp clauses ...)
     (handle-exceptions exvar
	 (let ([kvar (and (##sys#structure? exvar 'condition) (##sys#slot exvar 1))])
	   (condition-case "1" exvar kvar clauses ...) )
       exp) ] ) )

(define-syntax define-class
  (syntax-rules ()
    [(_ name () slots)
     (define-class name (<object>) slots) ]
    [(_ name supers slots)
     (define-class name supers slots <class>) ]
    [(_ name () slots meta)
     (define-class name (<object>) slots meta) ]
    [(_ cname (supers ...) (slots ...) meta)
     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )

(define-syntax define-generic
  (syntax-rules () 
    [(_ n class) (define n (make class 'name 'n))]
    [(_ n) (define n (make-generic 'n))] ) )

(define-syntax define-method
  (lambda (x)
    (syntax-case x ()
      [(_ "gather" name ((var spec) . rest) body (specs ...) (vars ...))
       (syntax (define-method "gather" name rest body (specs ... spec) (vars ... var))) ]
      [(_ "gather" name rest body (specs ...) (vars ...))
       (with-syntax ([call-next-method (datum->syntax-object (syntax name) 'call-next-method)])
	 (syntax
	  (set! name
	    (##tinyclos#add-global-method
	     (##core#global-ref name)
	     'name
	     (list specs ...)
	     (##core#named-lambda name (call-next-method vars ... . rest) . body)) ) ) ) ]
      [(_ (name . llist) body ...) 
       (syntax (define-method "gather" name llist (body ...) () ())) ] ) ) )

(define-syntax (define-record-type x)
  (define (memi id ids)
    (and (not (null? ids))
	 (or (free-identifier=? id (car ids))
	     (memi id (cdr ids)) ) ) )
  (syntax-case x ()
    [(_ t (conser vars ...) pred slots ...)
     (syntax-case #'(slots ...) ()
       [((slotnames . _) ...)
	(with-syntax ([(slotvars ...) (map (lambda (sname)
					     (if (memi sname #'(vars ...))
						 sname
						 #'(##sys#void) ) )
					   #'(slotnames ...)) ] )
	  (with-syntax ([(accforms ...)
			 (let loop ([slots #'(slots ...)] [i 1])
			   (if (null? slots)
			       #'()
			       (with-syntax ([ii i]
					     [(rest ...) (loop (cdr slots) (add1 i))] )
				 (syntax-case (car slots) ()
				   [(name get set)
				    #'((define (get x) 
					 (##sys#check-structure x 't)
					 (##sys#slot x ii) )
				       (define (set x y)
					 (##sys#check-structure x 't)
					 (##sys#setslot x ii y) ) 
				       rest ...) ]
				   [(name get)
				    #'((define (get x) 
					 (##sys#check-structure x 't)
					 (##sys#slot x ii) )  
				       rest ...) ] ) ) ) ) ] )
	    #'(begin
		(define t 't)
		(define (conser vars ...) (##sys#make-structure 't slotvars ...))
		(define (pred x) (##sys#structure? x 't))
		accforms ...) ) ) ] ) ] ) )

(define-syntax require-for-syntax
  (syntax-rules ()
    [(_ names ...) 
     (##core#require-for-syntax names ...) ] ) )

(define-syntax require-extension
  (syntax-rules ()
    [(_ names ...) (##core#require-extension 'names ...) ] ) )

(define-syntax use 
  (syntax-rules ()
    [(_ names ...) (##core#require-extension 'names ...) ] ) )

(define-syntax cut
  (syntax-rules (<> <...>)

    ;; construct fixed- or variable-arity procedure:
    ;;   (begin proc) throws an error if proc is not an <expression>
    ((_ "1" (slot-name ...) (proc arg ...))
     (lambda (slot-name ...) ((begin proc) arg ...)))
    ((_ "1" (slot-name ...) (proc arg ...) <...>)
     (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))

    ;; process one slot-or-expr
    ((_ "1" (slot-name ...)   (position ...)      <>  . se)
     (cut "1" (slot-name ... x) (position ... x)        . se))
    ((_ "1" (slot-name ...)   (position ...)      nse . se)
     (cut "1" (slot-name ...)   (position ... nse)      . se))

    ((_ . slots-or-exprs)
     (cut "1" () () . slots-or-exprs))) )

(define-syntax cute
  (syntax-rules (<> <...>)

    ;; If there are no slot-or-exprs to process, then:
    ;; construct a fixed-arity procedure,
    ((_ "1"
      (slot-name ...) nse-bindings (proc arg ...))
     (let nse-bindings (lambda (slot-name ...) (proc arg ...))))
    ;; or a variable-arity procedure
    ((_ "1"
      (slot-name ...) nse-bindings (proc arg ...) <...>)
     (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x))))

    ;; otherwise, process one slot:
    ((_ "1"
      (slot-name ...)         nse-bindings  (position ...)   <>  . se)
     (cute "1"
      (slot-name ... x)       nse-bindings  (position ... x)     . se))
    ;; or one non-slot expression
    ((_ "1"
      slot-names              nse-bindings  (position ...)   nse . se)
     (cute "1"
      slot-names ((x nse) . nse-bindings) (position ... x)       . se))

    ((cute . slots-or-exprs)
     (cute "1" () () () . slots-or-exprs))))

(define-syntax define-location
  (lambda (x)
    (syntax-case x ()
      [(_ name type) 
       (with-syntax ([alias (datum->syntax-object #'name 'loc)])
	 #'(begin
	     (##core#define-foreign-variable (quote name) (quote type) (quote alias))
	     (##core#define-external-variable (quote name) (quote type) (quote #f) (quote alias)) ) ) ]
      [(_ name type init)
       #'(begin
	   (define-location name type)
	   (##core#set! name init) ) ] ) ) )

(define-syntax let-location
  (syntax-rules ()
    [(_ "1" () bindings inits body)
     (let-location "2" bindings inits body) ]
    [(_ "1" ((name type init) . more) bindings (inits ...) body)
     (let ([alias init])
       (let-location "1" more bindings (inits ... alias) body) ) ]
    [(_ "1" ((name type) . more) bindings inits body)
     (let-location "1" more bindings inits body) ]
    [(_ "2" () () body) body]
    [(_ "2" ((name type) . more) inits body)
     (##core#let-location
      (quote name)
      (quote type)
      (let-location "2" more inits body) ) ]
    [(_ "2" ((name type init) . more) (inita . inits) body)
     (##core#let-location
      (quote name)
      (quote type)
      inita
      (let-location "2" more inits body) ) ]
    [(_ bindings body ...)
     (let-location "1" bindings bindings () (let () body ...)) ] ) )

(define-macro (foreign-code str)
  (let ([tmp (gensym 'code_)])
    `(begin
       (declare 
	 (foreign-declare
	  ,(sprintf "static C_word ~A() { ~A; return C_SCHEME_UNDEFINED; }\n" tmp str) ) )
       (##core#inline ,tmp) ) ) )

(define-macro (foreign-value str type)
  (let ([tmp (gensym 'code_)])
    `(begin
       (define-foreign-variable ,tmp ,type ,str)
       ,tmp) ) )

(define-macro (define-optimizer head . body)
  `(eval-when (compile)
     (##compiler#register-optimizer ',(car head) (lambda ,(cdr head) ,@body)) ) )