;;-*-lisp-*-
;; It is often desirable in maclisp to get the efficiency possible
;; by using non-reentrant static storage, while at the same time
;; allowing for buffer reallocations if calls are made recusively
;; or in breakpoints. Example usages are the tokenization level
;; of a parser, adaptive numerical integrators, graph calculators.

;; Here is one way to formalize,in terms of the STATE-VARIABLES
;; of a process, a need which can can otherwize lead
;; to some rather messy programs simply for the sake of efficiency.

;; Note: These macros are also usefull in any application with state
;; variables and clean-up, for example, Assemblers and Compilers,
;; in fact, any file processor.

;; Usage: (DEFSTATE <NAME> <VARIABLE-SPEC> <VARIABLE-SPEC> ...)
;; <VARIABLE-SPEC> : (<VARIABLE> <TOP-LEVEL-VAL>
;;                               <RECURSIVE-VAL>
;;                               <CLEAN-UP-CODE>)
;; Produces: (APPLY-IN-<NAME>-STATE ...) a function.
;;           (<NAME>-STATE-VARS) a function.
;;           (<NAME>-STATE-VALS) a function.
;;           (<NAME>-STATE-RECL) a function.

;; From my private macros 1:07pm  Wednesday, 25 February 1981 -GJC

(DECLARE (*LEXPR SYMBOLCONC))

;; This should be built-in
(eval-when (eval compile)
(DEFMACRO  (VARS . BODY) `#'(LAMBDA ,VARS . ,BODY)))

(HERALD DEFSTATE)

(DEFMACRO DEFSTATE (NAME . VARIABLE-SPECS)
	  (DO ((APPLY-FUN (SYMBOLCONC "APPLY-IN-" NAME "-STATE"))
	       (VAR-FUN (SYMBOLCONC NAME "-STATE-VARS"))
	       (VAL-FUN (SYMBOLCONC NAME "-STATE-VALS"))
	       (REC-FUN (SYMBOLCONC NAME "-STATE-RECL"))
	       (SPECS VARIABLE-SPECS (CDR SPECS))
	       (VARS NIL)
	       (VALS-TOP NIL)
	       (VALS-REC NIL)
	       (RECL NIL))
	      ((NULL SPECS)
	       (SETQ VARS (NREVERSE VARS)
		     VALS-TOP (NREVERSE VALS-TOP)
		     VALS-REC (NREVERSE VALS-REC)
		     RECL (NREVERSE RECL))
	       `(PROGN
		 'COMPILE
		 ,@(MAPCAR ( (A B) `(DEFVAR ,A ,B)) VARS VALS-TOP)
		 (DEFUN ,VAR-FUN () ',VARS)
		 (DEFUN ,VAL-FUN () (LIST ,@VALS-REC))
		 (DEFUN ,REC-FUN () ,@RECL)
		 (DEFUN ,APPLY-FUN (F L)
			(PROGV (,VAR-FUN)
			       (,VAL-FUN)
			       (UNWIND-PROTECT (APPLY F L)
					       (,REC-FUN))))))
	      (LET ((SPEC (IF (EQ (TYPEP (CAR SPECS)) 'LIST)
			      (CAR SPECS)
			      (ERROR "Bad variable spec" (CAR SPECS)))))
		   (PUSH (POP SPEC) VARS)
		   (PUSH (POP SPEC) VALS-TOP)
		   (PUSH (POP SPEC) VALS-REC)
		   (PUSH (POP SPEC) RECL))))