;;;; highlevel-macros.scm - CHICKEN specific syntax-case macros


(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 receive
  (lambda (x)
    (syntax-case x ()
      ((_ vars x0 x1 x2 ...)
       (syntax (##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 include
  (lambda (x)
    (syntax-case x ()
      ((_ filename) (syntax (##core#include 'filename))) ) ) )

(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 ...)
       (andmap identifier? (syntax (x ...)))
       (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) (##core#qualified (quote rtype)) (##core#qualified (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)
	(##core#qualified (quote rtype))
	(##core#qualified (quote (argtypes ...)))
	(lambda (argvars ...) body ...) ) ) ]
    [(_ (name (argtypes argvars) ...) rtype body ...)
     (define name
       (##core#foreign-callback-wrapper
	(quote name)
	(quote "")
	(##core#qualified (quote rtype))
	(##core#qualified (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)
     (##core#set! cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )

(define-syntax define-generic
  (syntax-rules () 
    [(_ name) (##core#set! name (make-generic 'name))] ) )

(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
	  (##tinyclos#add-global-method
	   '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
  (syntax-rules ()
    [(_ "1" type field-tag accessor)
     (define accessor (##sys#record-accessor type 'field-tag))]
    [(_ "1" type field-tag accessor modifier)
     (begin
       (define accessor (##sys#record-accessor type 'field-tag))
       (define modifier (##sys#record-modifier type 'field-tag)) ) ]
    [(_ type
	(constructor constructor-tag ...)
	predicate
	(field-tag accessor . more) ...)
     (begin
       (define type (##sys#make-record-type 'type '(field-tag ...)))
       (define constructor
         (##sys#record-constructor type '(constructor-tag ...)))
       (define predicate (##sys#record-predicate type))
       (define-record-type "1" type field-tag accessor . more)
       ...) ] ) )

(define-syntax require-for-syntax
  (syntax-rules ()
    [(_ names ...) 
     (##core#require-for-syntax 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 (define-entry-point . form)
  (##sys#check-syntax 'define-entry-point form '(_ list list . #(_ 1)))
  (let ([id (car form)]
	[args (cadr form)]
	[results (caddr form)]
	[body (cdddr form)]
	[wordsperdouble (lambda (n) (fx* n (##sys#fudge 8)))]
	[buffer (gensym)] )

    (define (convert-argument type index)
      (let ([err (lambda () (##sys#error "can not generate entry-point argument conversion for foreign type" type))])
	(case type
	  [(int unsigned-int) `(##sys#peek-fixnum ,buffer ,(wordsperdouble index))]
	  [(integer short long) `(##sys#peek-signed-integer ,buffer ,(wordsperdouble index))]
	  [(unsigned-integer unsigned-short unsigned-long)
	   `(##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)) ]
	  [(char) `(integer->char (##sys#peek-signed-integer ,buffer ,(wordsperdouble index)))]
	  [(unsigned-char) `(integer->char (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)))]
	  [(bool) `(not (eq? 0 (##sys#peek-fixnum ,buffer ,(wordsperdouble index))))]
	  [(nonnull-c-pointer nonnull-pointer c-pointer pointer)
	   `(##sys#address->pointer (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index))) ]
	  [(float double) `(##sys#peek-double ,buffer ,index)]
	  [(c-string nonnull-c-string) `(##sys#peek-c-string ,buffer ,(wordsperdouble index))]
	  [(scheme-object) `(##sys#slot ,buffer ,(wordsperdouble index))]
	  [else
	   (if (pair? type)
	       (case (car type)
		 [(pointer function) `(##sys#address->pointer (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)))]
		 [else (err)] )
	       (err) ) ] ) ) )

    (define (convert-result type index val)
      (let ([err (lambda () (##sys#error "can not generate entry-point result conversion for foreign type" type))])
	(case type
	  [(scheme-object) `(begin (##sys#gc) (##sys#setslot ,buffer ,(wordsperdouble index) ,val))]
	  [(int integer short long) `(##sys#poke-integer ,buffer ,(wordsperdouble index) ,val)]
	  [(unsigned-int unsigned-integer unsigned-short unsigned-long)
	   `(##sys#poke-integer ,buffer ,(wordsperdouble index) ,val) ]
	  [(char unsigned-char) `(##sys#poke-integer ,buffer ,(wordsperdouble index) (char->integer ,val))]
	  [(bool) `(##sys#poke-integer ,buffer ,(wordsperdouble index) (if ,val 1 0))]
	  [(c-pointer pointer nonnull-c-pointer nonnull-pointer byte-vector nonnull-byte-vector
		      u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector
		      nonnull-u8vector nonnull-u16vector nonnull-u32vector nonnull-s8vector 
		      nonnull-s16vector nonnull-s32vector nonnull-f32vector nonnull-f64vector)
	   `(##sys#poke-integer ,buffer ,(wordsperdouble index) (##sys#pointer->address ,val)) ]
	  [(float double) `(##sys#poke-double ,buffer ,index ,val)]
	  [(c-string nonnull-c-string) `(##sys#poke-c-string ,buffer ,(wordsperdouble index) ,val)]
	  [else
	   (if (pair? type)
	       (case (car type)
		 [(pointer function) `(##sys#poke-integer ,buffer ,(wordsperdouble index) (##sys#pointer->address ,val))]
		 [else (err)] )
	       (err) ) ] ) ) )

    `(##sys#register-entry-point
      ,id
      (lambda (,(gensym) ,buffer)
	(##sys#call-with-values
	 (lambda ()
	   (let ,(let loop ([args args] [i 0])
		   (if (null? args)
		       '()
		       (##sys#cons
			(##sys#list (caar args) (convert-argument (cadar args) i))
			(loop (cdr args) (fx+ i 1)) ) ) )
	     ,@body) )
	 (lambda resultvalues
	   ,(if (null? results)
		'(##core#undefined)
		(let loop ([results results] [args args] [i 0])
		  (let ([type (car results)])
		    (when (and (memq type '(c-string nonnull-c-string))
			       (or (null? args)
				   (not (memq (cadar args) '(c-string nonnull-c-string))) ) )
		      (##sys#error "can not return result of type `c-string' without corresponding string argument") )
		    (let ([r (convert-result type i '(car resultvalues))])
		      (if (null? (cdr results))
			  r
			  `(begin
			     ,r
			     (let ([resultvalues (cdr resultvalues)])
			       ,(loop (cdr results) (and (pair? args) (cdr args)) (fx+ i 1)) ) ) ) ) ) ) ) ) ) ) ) ) )

