git.fiddlerwoaroof.com
top/has-macros.scm
4e987026
 ;;; General macros for the Haskell compiler
 
 (define-syntax (remember-context exp . body)
   (let ((temp  (gensym)))
     `(let ((,temp  ,exp))
        (dynamic-let ((*context* (if (ast-node-line-number ,temp)
 				    ,temp 
 				    (dynamic *context*))))
          ,@body))))
 
 (define-syntax (maybe-remember-context exp . body)
   (let ((temp  (gensym)))
     `(let ((,temp  ,exp))
        (if (ast-node-line-number ,temp)
 	   (dynamic-let ((*context* ,temp)) ,@body)
 	   (begin ,@body)))))
 
 (define-syntax (recover-errors error-value . body)
   (let ((local-handler (gensym)))
     `(let/cc ,local-handler
        (dynamic-let ((*recoverable-error-handler*
 		       (lambda () (funcall ,local-handler ,error-value))))
          ,@body))))
 
 ;;; This is for iterating a list of contexts over a list of types.
 
 (define-syntax (do-contexts cbinder tbinder . body)
   (let ((cvar (car cbinder))
 	(cinit (cadr cbinder))
 	(tvar (car tbinder))
 	(tinit (cadr tbinder))
 	(cv (gensym))
 	(tv (gensym)))
     `(do ((,cv ,cinit (cdr ,cv))
 	  (,tv ,tinit (cdr ,tv)))
 	 ((null? ,cv))
        (let ((,tvar (car ,tv)))
 	 (dolist (,cvar (car ,cv))
 	   ,@body)))))
 
 ;; dolist for 2 lists at once.
 
 (define-syntax (dolist2 a1 a2 . body)
   (let ((a1var (car a1))
 	(a1init (cadr a1))
 	(a2var (car a2))
 	(a2init (cadr a2))
 	(a1l (gensym))
 	(a2l (gensym)))
     `(do ((,a1l ,a1init (cdr ,a1l))
 	  (,a2l ,a2init (cdr ,a2l)))
 	 ((null? ,a1l))
        (let ((,a1var (car ,a1l))
 	     (,a2var (car ,a2l)))
 	 ,@body))))