;;;; moremacros.scm  -*- Hen -*-
;;;; Kon Lovett, Aug '10

(module moremacros

  (;export
    (str# $conc$)
    ->boolean
    assure
    whennot
    type-case type-case*
    swap-set!
    fluid-set!
    stiff-set!
    set!/op
    ;must export helper macro, otherwise "hangs" during expansion of
    ;generated macro
    make-reference-let $grlaux$)

  (import scheme chicken (only data-structures conc))

  (import-for-syntax
    (only miscmacros repeat))

;;; Helpers

; maybe a problem with expansion environment namespace pollution
(define-for-syntax (make-identifier . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

(define $conc$ conc)

;;;

;; Expression templates

(define-syntax str#
  (ir-macro-transformer
    (lambda (frm inj cmp)
      (let* ((str (cadr frm))
             (strport (open-input-string str)) )
        (parameterize ((parentheses-synonyms #t))
          (let loop ((ls '()) (sl #f))
            (define (intstrlst chr)
              (if sl (cons chr sl) (list chr)) )
            (define (finstrlst)
              (if sl (cons (list->string (reverse sl)) ls) ls) )
            (let ((chr (read-char strport)))
              (cond
                ((eof-object? chr)
                  `($conc$ ,@(reverse (finstrlst))) )
                ((char=? #\# chr)
                  (let ((chr (peek-char strport)))
                    (cond
                      ((char=? #\# chr)
                        (let ((chr (read-char strport)))
                          (loop ls (intstrlst #\#)) ) )
                      ((char=? #\{ #;#\} chr)
                        (let ((ls (finstrlst))
                              (lst (read strport)) )
                          (loop (cons (inj (car lst)) ls) #f) ) )
                      (else
                        (let ((ls (finstrlst))
                              (exp (read strport)))
                          (loop (cons (inj exp) ls) #f) ) ) ) ) )
                (else
                  (loop ls (intstrlst chr)) ) ) ) ) ) ) ) ) )

;; Returns expression value or error

(define-syntax ->boolean
  (syntax-rules ()
    ((_ ?obj)
      (and ?obj
           #t) ) ) )

;; Returns expression value or error

(define-syntax assure
  (syntax-rules ()
    ((_ ?expr ?arg0 ?arg1 ...)
      (or ?expr
          (error ?arg0 ?arg1 ...)) ) ) )

;;

#;
(define-syntax reverse-literal-list
  (syntax-rules ()

    ((_)
      '() )

    ((_ ?elt)
      (list ?elt) )

    ((_ "aux" (?eltn ?eltn-1 ...))
      (list ?eltn ?eltn-1 ...) )

    ((_ "aux" (?elti-1 ?elti-2 ...) ?elti ?elti+1 ...)
      (reverse-literal-list "aux" (?elti ?elti-1 ?elti-2 ...) ?elti+1 ...) )

    ((_ ?elt0 ?elt1 ...)
      (reverse-literal-list "aux" (?elt0) ?elt1 ...) ) ) )

;; `Unless' synonym

(define-syntax whennot
  (syntax-rules ()
    ((_ ?condition ?body0 ...)
      (unless ?condition ?body0 ...) ) ) )

;;

(define-syntax ($type-case$ f r c)
  (let ((loc (cadr f))
        (?expr (caddr f))
        (?forms (cdddr f)) )
    (let ((var (if (c (r 'type-case*) loc) 'it (gensym))))
      (define (make-type-pred typnam)
        `(,(make-identifier typnam #\?) ,var))
      `(,(r 'let) ((,var ,?expr))
         (,(r 'cond)
           ,@(let loop ((forms ?forms)
                        (lst '()))
              (if (null? forms) (reverse lst)
                (let* ((tcase (car forms))
                       (typnam (car tcase))
                       (next (cdr forms)) )
                  (if (c (r 'else) typnam)
                    (if (null? next) (loop '() (cons (cons (r 'else) (cdr tcase)) lst))
                      (syntax-error loc "else form out of position" tcase) )
                    (loop (cdr forms)
                          (cons
                            (cons
                              (cond
                                ((symbol? typnam) (make-type-pred typnam) )
                                ((pair? typnam)   `(or ,@(map make-type-pred typnam)) )
                                (else
                                  (syntax-error loc "invalid case" tcase) ) )
                              (cdr tcase))
                            lst)) ) ) ) ) ) ) ) ) )

(define-syntax type-case
	(syntax-rules ()
		((_ ?expr (typ0 exp0 ...) ...)
      ($type-case$ type-case ?expr (typ0 exp0 ...) ...) ) ) )

(define-syntax type-case*
	(syntax-rules ()
		((_ ?expr (typ0 exp0 ...) ...)
      ($type-case$ type-case* ?expr (typ0 exp0 ...) ...) ) ) )

;; Exchange bindings of two variables

(define-syntax swap-set!
	(syntax-rules ()
		((_ ?a ?b)
      (let ((_tmp ?a))
       (set! ?a ?b)
       (set! ?b _tmp)) ) ) )

;; Parallel chained set

(define-syntax fluid-set!
	(syntax-rules ()

		((_ ?var ?val)
		  (set! ?var ?val) )

		((_ ?var ?val ?rest ...)
		  (let ((_tmp ?val))
		    (fluid-set! ?rest ...)
		    (set! ?var _tmp) ) ) ) )

;; Serial chained set (CL SETQ like)

(define-syntax stiff-set!
	(syntax-rules ()

		((_ ?var ?val)
		  (set! ?var ?val) )

		((_ ?var ?val ?rest ...)
		  (begin
		    (set! ?var ?val)
		    (stiff-set! ?rest ...) ) ) ) )

;; Assign the result of the operation on the variable to itself
;; Like C var <op>= <args>

; had a problem w/ `let-syntax' version of below:
; Error: during expansion of (syntax-rules ...) - too many ellipses: (?act1 ...)

(define-syntax $build-call$
  (syntax-rules (<>)

    ((_ ?op ?var)
      (?op ?var) )

    ((_ "aux" (?var #f) (?op ?act0 ...))
      (?op ?var ?act0 ...) )

    ((_ "aux" (?var #t) (?op ?act0 ...))
      (?op ?act0 ...) )

    ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
      ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )

    ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
      ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )

    ((_ ?op ?var <> ?arg0 ...)
      ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )

    ((_ ?op ?var ?arg0 ?arg1 ...)
      ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) )

(define-syntax set!/op
	(syntax-rules ()
		((_ ?var ?op ?rest ...)
		  (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) )

;;

(define-syntax $grlaux$
  (syntax-rules ()

    ;finished
    ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
      ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )

    ;
    ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
      ($grlaux$ "gen" (?loc ?item ?ref ?body)
        (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
        (?tup0 ...)) )

    ;all binds finished, generate
    ((_ "chk" ?cache ?tups ())
      ($grlaux$ "gen" ?cache () () ?tups) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

    ;start
    ((_ ?cache ?bnds)
      ($grlaux$ "chk" ?cache () ?bnds) ) ) )

(define-syntax make-reference-let
  (syntax-rules ()
    ((_ ?name ?ref)
      (define-syntax ?name
        (syntax-rules ::: ()
          ((_ ?item ?binds ?body0 :::)
            ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) )

#;
(define-syntax make-reference-let
  (er-macro-transformer
    (lambda (f r c)
      (##sys#check-syntax 'make-reference-let f '(_ symbol _))
      (let ((?name (cadr f))
            (?ref (caddr f)) )
        `(,(r 'define-syntax) ,?name
          (,(r 'syntax-rules) ()
            ((_ ?item ?binds ?body0 ...)
              (,(r '$grlaux$) (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )

#;
(define-syntax make-reference-let
  (ir-macro-transformer
    (lambda (f i c)
      (##sys#check-syntax 'make-reference-let f '(_ symbol _))
        (let ((?name (cadr f))
              (?ref (caddr f)) )
          `(define-syntax ,?name
            (syntax-rules ()
              ((_ ?item ?binds ?body0 ...)
                ($grlaux$ (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )

) ;module moremacros