;;; -*- Mode:LISP; Package:USER; Ibase:10; Base:10 -*-


(defmacro toggle ( foo )
  "Foo had better be a symbol!"
  `(setq ,foo (not ,foo)))

(defmacro togglef ( foo )
  "Foo had better be a setf-able form."
  `(setf ,foo (not ,foo)))

(defmacro pp () '(toggle *print-pretty*))

(defvar *redirect-trace-stack* nil "Stack used by redirect-trace to restore *trace-output* to its previous stream.")

(setq *redirect-trace-stack* () )

(defmacro redirect-trace ( &optional (file-name nil) )
  "If a file name is supplied trace's output will be redirected to the supplied
   file name's file otherwise trace's output will be redirected back to the stream
   where it previously went."
  (if file-name
      `(progn (push *trace-output* user:*redirect-trace-stack*)
	      (setq *trace-output* (open ,file-name :direction :output)))
    `(if (equal *trace-output* *terminal-io*)
	 *terminal-io*
       (close *trace-output*)
       (setq *trace-output*
	     (if (not (null user:*redirect-trace-stack*))
		 (pop user:*redirect-trace-stack*)
	       *terminal-io*)))))

(defmacro Defined-Where? ( function-name )
  `(second (car (get ,function-name :source-file-name))))

(defun d> (path) (string-append "lam15:devoy;" path))

(defun concatenate-files ( &rest files )
  (let* ((source-files (reverse (cdr (reverse files))))
	 (target-file  (car (last files)))
	 (streams      (mapcar 'open source-files))
	 (stream       (apply 'make-concatenated-stream
			      streams))
	 (result       (copy-file stream target-file)))
    (list result (mapcar 'close (cons stream streams)))))

(defmacro define-path (alias path)
  `(defun ,alias (&optional (tail? nil))
     (let ((path ,path))
       (if tail?
	   (string-append path (if (stringp tail?)
				   tail?
				 (eval tail?)))
	 path))))

(define-path devoy     "lam15:devoy;")
(define-path angel     "lmi-angel://lmi//devoy")
(define-path pic       "lam15:pic;")
(define-path icm       "ike-case-modeling")
(define-path icm.l     "ike-case-modeling.lisp")
(define-path id        "ike-domain")
(define-path id.l      "ike-domain.lisp")
(define-path ir        "ike-root")
(define-path ir.l      "ike-root.lisp")
(define-path p-icm     "lam15:pic;ike-case-modeling")
(define-path p-icm.l   "lam15:pic;ike-case-modeling.lisp")
(define-path d-icm     "lam15:devoy;ike-case-modeling")
(define-path d-icm.l   "lam15:devoy;ike-case-modeling.lisp")
(define-path angel-icm "lmi-angel://lmi//devoy//icm.lisp")

(defvar lisp  ".lisp")
(defvar qfasl ".qfasl")
(defvar text  ".text")



(defmacro let-trace ( var-list &body body )
  (let* ((local-var (gensym))
	 (new-var-list (loop for assignment in var-list
			     collecting (cond ((atom assignment)
					       `(,assignment
						 (progn (format *trace-output*
								"~%~S = nil~%"
								(quote ,assignment))
							nil)))
					      ((null (cdr assignment))
					       `(,(car assignment)
						 (progn (format *trace-output*
								"~%~S = nil~%"
								(quote ,(car assignment)))
							nil)))
					      (t `( ,(car assignment) (let ((,local-var ,(cons 'progn (cdr assignment))))
									(format *trace-output*
										"~%~S = ~S~%"
										(quote ,(car assignment)) ,local-var)
									,local-var)))))))
    `(let ,new-var-list ,@ body)))

(defmacro let*-trace ( var-list &body body )
  (let* ((local-var (gensym))
	 (new-var-list (loop for assignment in var-list
			     collecting (cond ((atom assignment)
					       `(,assignment
						 (progn (format *trace-output*
								"~%~S = nil~%"
								(quote ,assignment))
							nil)))
					      ((null (cdr assignment))
					       `(,(car assignment)
						 (progn (format *trace-output*
								"~%~S = nil~%"
								(quote ,(car assignment)))
							nil)))
					      (t `( ,(car assignment) (let ((,local-var ,(cons 'progn (cdr assignment))))
									(format *trace-output*
										"~%~S = ~S~%"
										(quote ,(car assignment)) ,local-var)
									,local-var)))))))
    `(let* ,new-var-list ,@ body)))

(defvar *trace-on-off-memory-stack* nil)
(setq *trace-on-off-memory-stack* nil)

(defmacro trace-on ( &rest more-functions )
  `(trace ,@(append more-functions (pop *trace-on-off-memory-stack*))))

(defmacro trace-off ( &rest functions )
  `(push (untrace ,@functions) *trace-on-off-memory-stack*))