root/release/3/riaxpander/riaxpander-chicken-macros.scm

;;;; riaxpander-chicken-macros.scm
;;;; (adapted from syntactic-closures-chicken-macros.scm)

(define-syntax define-macro
  (syntax-rules ()
    ((_ (id . llist) . body) 
     (define-syntax id
       (rsc-macro-transformer 
  (lambda (exp env)
    (apply (lambda llist . body) (cdr exp))))))
    ((_ id expander) 
     (define-syntax id
       (rsc-macro-transformer 
  (lambda (exp env)
    (apply expander (cdr exp))))))))

(define-syntax include
  (rsc-macro-transformer
   (lambda (exp env)
     (syntax-check '(keyword expression) exp)
     (let ((filename (cadr exp)))
       (let ((path (##sys#resolve-include-filename filename #t)))
   (if (load-verbose) (print "; including " path " ..."))
   `(,(make-syntactic-closure env '() 'begin)
     ,@(with-input-from-file path
         (lambda ()
     (do ((x (read) (read))
          (xs '() (cons x xs)))
         ((eof-object? x) 
          (reverse xs)))))))))))

(define-syntax cond-expand
  (sc-macro-transformer
   (lambda (form env)
     (capture-syntactic-environment
      (lambda (transformer-env)
  
  (define (err x) 
    (syntax-error "syntax error in `cond-expand' form" x form))
  (define (literal=? usage-id transformer-id)
    (and (identifier? usage-id)
         (identifier=? env usage-id transformer-env transformer-id)))
  (define (close-forms forms)
    (map (lambda (form) (make-syntactic-closure env '() form)) forms))
  (define (test fx)
    (cond ((identifier? fx)
     (##sys#feature? (identifier->symbol fx)))
    ((not (pair? fx)) (err fx))
    (else
     (let ((bool (##sys#slot fx 0))
           (rest (##sys#slot fx 1)))
       (if (literal=? bool bool)
           (case bool
       ((and)
        (or (eq? rest '())
            (if (pair? rest)
          (and (test (##sys#slot rest 0))
               (test `(and ,@(##sys#slot rest 1))))
          (err fx))))
       ((or) 
        (and (not (eq? rest '()))
             (if (pair? rest)
           (or (test (##sys#slot rest 0))
               (test `(or ,@(##sys#slot rest 1))))
           (err fx))))
       ((not) (not (test (cadr fx))))
       (else (err fx)))
           (err fx))))))

  (let ((clauses (cdr form)))
    (let expand ((cls clauses))
      (cond ((null? cls)
       (##sys#apply
        ##sys#error "no matching clause in `cond-expand' form" 
        (map car clauses)))
      ((not (pair? cls)) (err cls))
      (else
       (let ((clause (##sys#slot cls 0))
       (rclauses (##sys#slot cls 1)))
         (if (not (pair? clause)) 
       (err clause)
       (let ((id (##sys#slot clause 0)))
         (cond ((literal=? id 'else)
          (let ((rest (##sys#slot clause 1)))
            (if (null? rest)
          '(##core#undefined)
          `(begin ,@(close-forms rest)))))
         ((test id) `(begin ,@(close-forms
                   (##sys#slot clause 1))))
         (else (expand rclauses)))))))))))))))

(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 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
  (syntax-rules ()
    ((_ 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 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 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)
     (##core#check (##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 let*-values
  (syntax-rules ()
    ((_ () exp1 ...) (let () exp1 ...))
    ((_ (binding0 binding1 ...) exp0 exp1 ...)
     (let-values (binding0)
       (let*-values (binding1 ...) exp0 exp1 ...)))))

(define-syntax let-values
  (syntax-rules ()
    ((let-values (?binding ...) ?body0 ?body1 ...)
     (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))

    ((let-values "bind" () ?tmps ?body)
     (let ?tmps ?body))

    ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
     (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))

    ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
     (call-with-values 
       (lambda () ?e0)
       (lambda ?args
         (let-values "bind" ?bindings ?tmps ?body))))

    ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
     (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))

    ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
     (call-with-values
       (lambda () ?e0)
       (lambda (?arg ... . x)
         (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))

(define-syntax switch
  (syntax-rules (else)
    ((_ v (else e1 e2 ...))
     (begin e1 e2 ...))
    ((_ v (k e1 e2 ...))
     (let ((x v))
       (if (eqv? x k) (begin e1 e2 ...))))
    ((_ v (k e1 e2 ...) c1 c2 ...)
     (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 (##core#check (##sys#error (##core#immutable '"too many optional arguments") tmp))))))))

(define-syntax :optional    ; DEPRECATED
  (syntax-rules ()
    ((_ . rest) (optional . rest))))

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

;; Just generates temp variables for let-optionals*
;; then binds them in one application, faster than
;; Shiver's let-optionals.

(define-syntax let-optionals
 (syntax-rules ()
   ((let-optionals ("step") rest (tmps ...) ((var default) . vars) body)
    (let-optionals ("step") rest (tmps ... (var tmp default)) vars body))
   ((let-optionals ("step") rest ((var tmp default) ...) () body)
    (let-optionals* rest ((tmp default) ...)
      (let ((var tmp) ...)
        body)))
   ((let-optionals rest vars body ...)
    (let-optionals ("step") rest () vars (begin body ...)))))

(define-syntax define-inline
  (syntax-rules ()
    ((_ head . body)
     (define head . body))))

(define-syntax define-constant
  (syntax-rules ()
    ((_ name val) (define name val))))

(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 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 require-extension)

(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 let-string-start+end
  (syntax-rules ()
    ((let-string-start+end (start end) proc s-exp args-exp body ...)
     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
       body ...))
    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
     (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
       body ...))))

(define-syntax rec
  (syntax-rules ()
    ((rec (NAME . VARIABLES) . BODY)
     (letrec ( (NAME (lambda VARIABLES . BODY))) NAME))
    ((rec NAME EXPRESSION)
     (letrec ( (NAME EXPRESSION)) NAME))))

(define-syntax define-record
  (sc-macro-transformer
   (lambda (form env)
     (define (identifier->string x)
       (symbol->string (identifier->symbol x)))
     (define construct-name
       (lambda (prefix . args)
   (##sys#string->qualified-symbol
    prefix
    (##sys#apply string-append
           (map (lambda (x) (if (string? x) x (identifier->string x)))
          args)))))
     (syntax-check '(keyword identifier * identifier) form)
     (let* ((name (cadr form))
      (slots (cddr form))
      (setters (memq #:record-setters ##sys#features))
      (prefix (##sys#qualified-symbol-prefix (identifier->symbol name))))
       (capture-syntactic-environment
  (lambda (xenv)
    (define (close id)
      (make-syntactic-closure xenv '() id))
    `(begin
       (define ,(construct-name prefix "make-" name)
         (lambda ,slots (,(close '##sys#make-structure) ',name ,@slots)))
       (define ,(construct-name prefix name "?")
         (lambda (x) (##sys#structure? x ',name)))
       ,@(let mapslots ((slots slots) (i 1))
     (if (eq? slots '())
         slots
         (let* ((slotname (identifier->string (##sys#slot slots 0)))
          (setr (construct-name prefix name "-" slotname "-set!"))
          (getr (construct-name prefix name "-" slotname)))
           (cons
      `(begin
         (define ,setr
           (lambda (x val)
             (##core#check (##sys#check-structure x ',name))
             (##sys#block-set! x ,i val)))
         (define ,getr
           ,(if setters
          `(getter-with-setter
            (lambda (x) 
              (##core#check (##sys#check-structure x ',name))
              (##sys#block-ref x ,i))
            ,setr)
          `(lambda (x)
             (##core#check (##sys#check-structure x ',name))
             (##sys#block-ref x ,i)))))
      (mapslots (##sys#slot slots 1) (fx+ i 1)))))))))))))

;; syntactic-closures uses letrec semantics for internal defines, so we
;; have to defer any getter-with-setter calls until the end of the body.
(define-syntax define-record-type
  (sc-macro-transformer
   (lambda (form env)
     (define (memi id ids)
       (and (not (null? ids))
      (or (identifier=? env id env (car ids))
    (memi id (cdr ids)))))
     (define (close id)
       (make-syntactic-closure env '() id))
     (syntax-check '(keyword identifier (+ identifier)
           identifier * (+ identifier)) form)
     (let ((t (cadr form))
     (conser (caddr form))
     (pred (cadddr form))
     (slots (cddddr form)))
       (let ((vars (cdr conser))
       (slotnames (map car slots))
             (setters? (memq #:record-setters ##sys#features)))

   `(begin
      (define ,conser
        (##sys#make-structure 
         ',t 
         ,@(map (lambda (sname)
      (if (memi sname vars)
          sname
          '(##sys#void)))
          slotnames)))
      (define (,pred x) (##sys#structure? x ',t))
      ,@(let loop ((slots slots) (i 1) (deferred-sets '()))
    (if (null? slots)
        deferred-sets
        (let* ((slot (car slots))
         (get (cadr slot))
         (set (and (pair? (cddr slot)) (caddr slot)))
         (getr `(lambda (x)
            (##core#check (##sys#check-structure x ',t))
            (##sys#block-ref x ,i)))
         (get/set (and set setters?
           `(set! ,(close get)
            (getter-with-setter ,getr ,(close set))))))
          `(,@(if set
            `((define (,set x y)
          (##core#check (##sys#check-structure x ',t))
          (##sys#block-set! x ,i y)))
            '())
      (define ,get ,(if get/set (##sys#void) getr))
      ,@(loop (cdr slots) (add1 i)
        (if get/set
            (cons get/set deferred-sets)
            deferred-sets))))))))))))

(define-syntax define-extension
  (sc-macro-transformer
   (lambda (form env)
     (syntax-check '(keyword identifier * (identifier * expression)) form)
     (capture-syntactic-environment
      (lambda (xenv)
  (define (literal=? usage-id transformer-id)
    (and (identifier? usage-id)
         (identifier=? env usage-id xenv transformer-id)))
  (define (close expr)
    (make-syntactic-closure env '() expr))

  (let ((name (identifier->symbol (cadr form)))
        (clauses (cddr form)))
   (let loop ((s '()) (d '()) (cs clauses) (exports #f))
     (if (null? cs)
         (let ((exps (if exports `(declare (export ,@(map close exports))) '(begin))))
     `(cond-expand
       (chicken-compile-shared ,exps ,@d)
       ((not compiling) ,@d)
       (else 
        (declare (unit ,name))
        ,exps
        (provide ',name) 
        ,@s))) 
         (let ((t (caar cs))
         (next (cdr cs)))
     (cond ((literal=? t 'static)  (loop (cons `(begin ,@(map close (cdar cs))) s) d next exports))
           ((literal=? t 'dynamic) (loop s (cons `(begin ,@(map close (cdar cs))) d) next exports))
           ((literal=? t 'export)  (loop s d next (append (or exports '()) (cdar cs))))
           (else (syntax-error 'define-extension "invalid clause specifier" t))))))))))))

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

(define-syntax fluid-let
  (syntax-rules ()
    ((_ ((v1 e1) ...) b1 b2 ...)
     (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
    ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     (let ((temp e1))
       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
    ((_ "temps" ((t e v) ...) () b1 b2 ...)
     (let-syntax ((swap!
                   (syntax-rules ()
                     ((swap! a b)
                      (let ((tmp a))
                        (set! a b)
                        (set! b tmp))))))
       (dynamic-wind
        (lambda ()
          (swap! t v) ...)
        (lambda ()
          b1 b2 ...)
        (lambda ()
          (swap! t v) ...))))))