(char-name 'NUL (integer->char 0))
(char-name 'nul (integer->char 0))
(char-name 'cr (integer->char 13))

(define-macro (flush-output-port port) `(flush-output ,port))

;; receive* is a hack used to migrate from the rscheme 'bind'
;; construct to normal receive.
(define-macro (receive* vars expr . body)
  `(receive ,vars ,expr . ,body))

(define-macro (receive-srfi vars expr . body)
  `(call-with-values (lambda () ,expr)
                     (lambda ,vars . ,body)))

(define-macro (semaphore-wait sema) `(semaphore-wait-by! ,sema 1))
(define-macro (semaphore-signal sema) `(semaphore-signal-by! ,sema 1))

(define-macro (with-semaphore sema . body)
  `(dynamic-wind
    (lambda () (semaphore-wait-by! ,sema 1))
    (lambda () . ,body)
    (lambda () (semaphore-signal-by! ,sema 1))))

(define-macro (with-mutex mutex . body)
  `(dynamic-wind
    (lambda () (mutex-lock! ,mutex))
    (lambda () . ,body)
    (lambda () (mutex-unlock! ,mutex))))

(define-macro (future expr name) `(thunk->future (lambda () ,expr) ,name))

;; SRFI 34

; (define-macro (guard clause . body)
;   (let ([k (gensym)]
; 	[args (gensym)] )
;     `((call-with-current-continuation
;        (lambda (,k)
; 	 (with-exception-handler
; 	  (lambda (,(car clause))
;             (,k (lambda () (cond ,@(cdr clause)
;                                  ,@(if (assq 'else (cdr clause))
;                                        '()
;                                        `((else (raise ,(car clause)))))))))
; 	  (lambda ()
; 	    (##sys#call-with-values
; 	     (lambda () ,@body)
; 	     (lambda ,args (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) )) ) )


(define-macro (guard . form)
  (let* ((clause (or (and (pair? form) (car form))
                     (error "guard: syntax error in" form)))
         (body (cdr form)))
    `(with-exception-guard
      (lambda (,(car clause))
        ,(let loop ((clauses (cdr clause)))
           (if (null? clauses)
               `(raise ,(car clause))
               (let ((c (car clauses)))
                 (cond
                  ((eq? 'else (car c))
                   (if (null? (cdr c))
                       '#f
                       (if (null? (cddr c))
                           (cadr c)
                           `(begin . ,(cdr c)))))
                  ((and (pair? c) (pair? (cdr c)) (eq? '=> (cadr c)))
                   (let ((v (gensym)))
                     `(let ((,v ,(car c)))
                        (if ,v (,(caddr c)) ,(loop (cdr clauses))))))
                  ((and (pair? c) (null? (cdr c)))
                   (let ((v (gensym)))
                     `(let ((,v ,(car c)))
                        (if ,v ,v ,(loop (cdr clauses))))))
                  ((pair? c)
                   `(if ,(car c)
                        ,(if (null? (cddr c))
                             (cadr c)
                             `(begin . ,(cdr c)))))
                  (else (error "guard syntax error in ~a" c)))))))
      (lambda ()
        ,(if (and (pair? body) (null? (cdr body)))
             (car body) `(begin . ,body) )))))

;; SRFI 35
(define-macro (define-condition-type ?name ?supertype ?predicate . fspecs)
  `(begin
     (define ,?name
       (make-condition-type ',?name
			    ,?supertype
			    ',(map car fspecs)))
     (define (,?predicate thing)
       (and (condition? thing)
	    (condition-has-type? thing ,?name)))
     . ,(map
	 (lambda (f)
	   `(define (,(cadr f) condition)
	      (condition-ref (extract-condition condition ,?name)
			     ',(car f))))
	 fspecs)))

(define-macro (condition . args)
  (cons
   'type-field-alist->condition
   (map
    (lambda (arg)
      (cons (car arg)
	    (map (lambda (f) (cons (car f) (cadr f))) (cdr arg))))
    args)))

(define-macro (lalr-parser . arguments)
  (apply gen-lalr-parser arguments))

(define-macro (pcre-lalr-parser scan . arguments)
  `(let ((parser ,(apply gen-lalr-parser arguments))
         (scanner (make-pcre-tokeniser ',scan)))
     (lambda (str)
       (receive (tokens position) (scanner str)
                (guard
                 (condition
                  (else
                   (receive
                    (title msg args rest) (condition->fields condition)
		    (error (format "~a\n~a in:\n~a\n~a" title msg str args)))))
                 (parser tokens error-for-lalr))))))

(define-macro (%early-once-only . body) `(begin . ,body))

;; FIXME these should go somewhere into tree.scm
(define-macro (%node-list-cons snl nl) `(cons ,snl ,nl))
(define-macro (%node-list-append . nl) `(append . ,nl))

(define-macro (make-xml-literal data) data)
(define-macro (xml-literal-value lit) lit)

(define-macro (empty-node-list) ''())   ; dsssl 10.2.2

(define-macro (define-transformer symbol . body)
  `(define (,symbol
            place
            message
	    root-node
            variables
	    namespaces
            ancestor
            self-node
            nl
            mode-choice
            proc-chain
            ) . ,body))

(define-macro (lambda-transformer . body)
  `(lambda (place
            message
	    root-node
            variables
	    namespaces
            ancestor
            self-node
            nl
            mode-choice
            proc-chain
            )
     . ,body))

(define-macro (lambda-process . body)
  `(lambda (place
            message
	    root-node
            variables
	    namespaces
            ancestor
            self-node
            nl
            mode-choice
            ) . ,body))

(define-macro (apply-transformer proc)
  `(,proc place
          message
	  root-node
          variables
	  namespaces
          ancestor
          self-node
          nl
          mode-choice
          proc-chain
          ))

(define-macro (xml-walk-down . arguments)
  (do ((args arguments (cddr args))
       ;; S*** please help me someone with that macro!!!
       ;; TODO compute these defaults from xml-transformer-arguments
       (place 'place) (message 'message)
       (root-node 'root-node)
       (variables 'variables)
       (namespaces 'namespaces)
       (ancestor 'ancestor) (self-node 'self-node)
       (nl 'nl)
       (proc-chain 'proc-chain) (mode-choice 'mode-choice)
       )
      ((null? args)
       (list proc-chain
             place message root-node variables namespaces ancestor self-node nl
             mode-choice))
    (let ((value (if (null? (cdr args))
                     (error "xml-walk-down misses arg for ~a" (car args))
                     (cadr args))))
      (case (car args)
        ((ancestor:) (set! ancestor value))
        ((variables:) (set! variables value))
	((namespaces:) (set! namespaces value))
        ((self-node:) (set! self-node value))
        ((sosofos:) (set! nl value))
        ((process:) (set! proc-chain value))
        ((continue:) (set! mode-choice value))
	((root-node:) (set! root-node value))
        (else (error "xml-walk-down unsupported: ~a" (car args)))))))

;; place.scm

(include "../mechanism/place-macros.scm")

(define-macro (define-atomic-type type-name 
                constructor-name+field-tags
		define-update-name
                predicate-name
                . field-specs)
  (begin
    (define constructor-name (car constructor-name+field-tags))
    (define field-tags (cdr constructor-name+field-tags))
    (define (fs-name fs) (car fs))
    (define (fs-accessor fs) (cadr fs))
    (define (fs-mutable fs) (and (pair? (cddr fs))
				 (eq? (caddr fs) ':mutable)))
    (define (field-spec fs)
      (list (fs-name fs) (fs-accessor fs)))
    (define object (gensym))
    (define outer-object (gensym))
    (define get-proc (gensym))
    (define exch-proc (gensym))
    (define proc (gensym))
					;
    `(begin
       (define-record-type ,type-name
	 (,constructor-name . ,field-tags)
	 ,predicate-name
	 . ,(map field-spec field-specs))

       (define-macro (,define-update-name update-method
		       input-fields update-fields arguments results
		       . body)
	 (let* ((updater (gensym))
		(update-method2 (string->symbol (string-append (symbol->string update-method) "!")))
		(typename ',type-name)
		(constructor-name ',constructor-name)
		(object ',object)
		(outer-object ',outer-object)
		(get-proc ',get-proc)
		(exch-proc ',exch-proc)
		(getterlist (let loop ((field-specs ',field-specs))
			      (if (null? field-specs) '()
				  (if (memq (car (car field-specs))
					    input-fields)
				      (cons `(,(cadr (car field-specs)) ,object)
					    (loop (cdr field-specs)))
				      (loop (cdr field-specs))))))
		(makelist (let loop ((field-specs ',field-specs))
			    (if (null? field-specs) '()
				(let ((name (car (car field-specs))))
				  `(,(if (memq name update-fields)
					 name
					 `(,(cadr (car field-specs)) ,object))
				    . ,(loop (cdr field-specs))))))))
	   `(begin
	      (define ,update-method
		(let ((,updater (lambda (,@input-fields ,@arguments) . ,body)) )
		  (define (,update-method ,object ,@arguments)
		    (call-with-values
			(lambda () (,updater ,@getterlist ,@arguments))
		      (lambda (,@results ,@update-fields)
			(values
			 ,@results
			 (,constructor-name . ,makelist)))))
		  ,update-method))
	      (define ,update-method2
		(let ((,updater (lambda (,@input-fields ,@arguments) . ,body)) )
		  (define (,update-method2 ,outer-object ,get-proc ,exch-proc ,@arguments)
		    (define ,object (,get-proc ,outer-object))
		    (call-with-values
			(lambda () (,updater ,@getterlist ,@arguments))
		      (lambda (,@results ,@update-fields)
			(let ((result (,constructor-name . ,makelist)))
			  (if (not (eq? (,exch-proc ,outer-object ,object result) result))
			      (error "raise condition in ~a on ~a for ~a" ,update-method2 ,object result))
			  (values ,@results result)))))
		  ,update-method2)))))
       )))
(include "../mechanism/protocol/macros.scm")
(include "../mechanism/storage/macros.scm")