;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- 
;;; $Header: /ct/ctlisp/aip.l,v 1.18 85/06/21 12:34:08 bill Exp $
;
;;;
;;; Hacked 14 August 1985 Richard Mark Soley for Lambda port.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                               AIP                                ;;;
;;; Paul Robertson                                         30-Jan-83 ;;;
;;; Edits by Mark Miller, John Shelton, Gene Ciccarelli     5-Apr-83 ;;;
;;; Edit by Mark Miller to add si:xr-bq-cons kludge.       12-May-83 ;;;
;;; Edit by Mark Miller to flush LISTP calls in records.   15-May-83 ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;;          Functions and Macros from Charniak et al.(modified)     ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   Charniak et al., 198?.  Artificial Intelligence Programming.   ;;;
;;;                                                                  ;;;
;;; The following code assumes familiarity with the above.           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; NB:  To do -- merge this with compat, etc., eventually.  ++mlm

;;; AIP Assembled by Paul Robertson.
;;; This file contains the c*tlisp macros and functions based on those found
;;; in the AIP book. They are to be the Prefered way of structuring data and
;;; control in c*t programs. The primary objective is to provide a set of
;;; structuring facilities that can be readily transported to other lisps. A
;;; compatible c*tlisp facility will be maintained on the lisp machine. Franz
;;; lisp should be used in maclisp compatability mode, functions should be
;;; defined with the maclisp compatible defun and the liszt compiler should be
;;; called with the -m (maclisp) switch. Macro and function names have been
;;; changed where necessary, to avoid name clashes and transportability
;;; problems. In particular, all occurences of hyphen have been replaced with
;;; underscore eg. record-type has been changed to record_type etc.
;;; In addition all occurences of : have been replaced with %. This overcomes
;;; LM's usage of colon for packages. So (record_type foo (a b . c)) will
;;; produce selector macros a%foo b%foo and c%foo. Also the assignment macro
;;; has been changed to %= for the same reason.

#+LMI
(eval-when (eval compile load)
(setq si:*all-free-interpreter-variable-references-special* 't))

#+franz (declare (macros t))

(declare (*fexpr form2 addspec))
(declare (special vars *type* *l* item l  dis_tree goal and or not
		  eval harray *assoclist* *form* inst pat *table_size*
		  *maclobsw* sk1 sk2 sk2h))

;(eval-when (eval) (setq *maclobsw* t)); commented out 10-25-83
#+lispm(eval-when (compile load) (setq *maclobsw* nil)); conditionalized pmj 18-3-84

#+franz(eval-when (compile load eval) (setq *maclobsw* t)); wab 10-25-83

;;;  We ct_load polly later in the file.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

#+franz
(eval-when (compile load eval) 
    (putd 'consp (getd 'dtpr))		  ;rename franz DTPR to CONSP
    (putd 'fset  (getd 'putd))
    (putd 'sxhash (getd 'maknum))
    (putd 'fsymeval (getd 'getd)))


;;;  temporary definition guaranteed not to clash with anything.
#+lispm
(eval-when (compile load eval)
  (defun consp_temp macro (form)
       ;; This crock assumes that (listp nil) --> nil on the lisp
       ;; machine, which is the current case.  ++mlm
       `(listp ,(cadr form))))


;;;  What a losing crock.  Turns out that TWO LISPMs with the same
;;; microcode are different!  One lispmachine has CONSP defined, and
;;; the other doesn't.  This takes care of that, while leaving stuff
;;; as compiled as possible.    +++
#+lispm
(eval-when (compile load eval)
  (cond ((not (fboundp 'consp))
	 (fset 'consp (fsymeval 'consp_temp)))))


;;;COMPILING-P returns non-nil when the enclosing function is being compiled.

#+lispm
(eval-when (compile load eval)
(defun compiling-p nil
#+3600  (status feature complr)
#+(or CADR LMI)  (si:function-active-p 'compiler:compile-form-function)))


;;;  Set up the definition for selfinsertmacro, which clobbers
;;; the caller if *maclobsw* is T and if we're not being compiled.

(eval-when (compile load eval)
(defun selfinsertmacro (call expansion)
    (cond
        ((and *maclobsw*
	      (consp expansion)
	      #+lispm (not (compiling-p)) ;;are we not in the compiler?
	      )
	    (rplaca call (car expansion))
	    (rplacd call (cdr expansion))
	    call)
	(t expansion))))

#+lispm
(eval-when (compile load eval)
  (defun concat  (&rest **l**)
    (intern (apply 'string-append **l**))))

#+lispm (defun caaaddr macro (l)
	       (selfinsertmacro l `(caar (caddr ,(cadr l)))))

#+lispm (defun cadaaddr macro (l)
	        (selfinsertmacro l `(cadar (caddr ,(cadr l)))))

#+lispm (defun caddddddr macro (l)
	        (selfinsertmacro l `(cadddr (cdddr ,(cadr l)))))

#+lispm (defun caddddr macro (l)
	        (selfinsertmacro l `(cadddr (cdr ,(cadr l)))))

#+lispm (defun cadddddr macro (l)
	        (selfinsertmacro l `(cadddr (cddr ,(cadr l)))))

#+lispm (defun caddddddr macro (l)
	        (selfinsertmacro l `(cadddr (cdddr ,(cadr l)))))

#+lispm (defun cadddddddr macro (l)
	        (selfinsertmacro l `(cadddr (cddddr ,(cadr l)))))

#+lispm (defun caddddddddr macro (l)
	        (selfinsertmacro l `(caddddr (cddddr ,(cadr l)))))

#+lispm (defun cadddddddddr macro (l)
	        (selfinsertmacro l `(caddddr (cdddddr ,(cadr l)))))

#+lispm (defun cdddddr macro (l)
	        (selfinsertmacro l `(cdddr (cddr ,(cadr l)))))

#+lispm (defun cddddddr macro (l)
	        (selfinsertmacro l `(cdddr (cdddr ,(cadr l)))))

#+lispm (defun cdddddddr macro (l)
	        (selfinsertmacro l `(cdddr (cddddr ,(cadr l)))))

#+franz (defun first   macro (l) (selfinsertmacro l `(car ,(cadr l))))
#+franz (defun second  macro (l) (selfinsertmacro l `(cadr ,(cadr l))))
#+franz (defun third   macro (l) (selfinsertmacro l `(caddr ,(cadr l))))
#+franz (defun fourth  macro (l) (selfinsertmacro l `(cadddr ,(cadr l))))
#+franz (defun fifth   macro (l) (selfinsertmacro l `(caddddr ,(cadr l))))
#+franz (defun sixth   macro (l) (selfinsertmacro l `(cadddddr ,(cadr l))))
#+franz (defun seventh macro (l) (selfinsertmacro l `(caddddddr ,(cadr l))))

#-LMI
(defun eighth macro (l) (selfinsertmacro l `(cadddddddr ,(cadr l))))

#-LMI
(defun ninth  macro (l) (selfinsertmacro l `(caddddddddr ,(cadr l))))

#-LMI
(defun tenth  macro (l) (selfinsertmacro l `(cadddddddddr ,(cadr l))))

;;;
;;; ucilisp do loop,  
;;;

(defun uci_do macro (l)
(selfinsertmacro l
  ((lambda (dotype alist)
	   (cond ((eq dotype 'while)
		  (dowhile (car alist) (cdr alist)))
		 ((eq dotype 'until)
		  (dowhile (list 'not (car alist))
			   (cdr alist)))
		 ((eq dotype 'for)
		  (dofor (car alist) 
			 (cadr alist)
			 (caddr alist)
			 (cdddr alist)))
		 (t `((lambda ()
			      ,@alist)))))
   (cadr l)
   (cddr l))))

(defun dowhile (expr alist)
    `(prog (returnvar)
	 loop
	 (cond (,expr
		   (setq returnvar ((lambda ()
					,@alist)))
		   (go loop))
	     (t (return returnvar)))))

;;;  This seems wrong somehow, because later in the file we define
;;; ct_selectq, as if there were something wrong with the real
;;; selectq.  Paul might want to check this out.
;;;   We don't understand how this code works, but we changed the
;;; the selectq to a cond for safety.
;;;
;;;                         --John & Mark, 5-Apr-83.
(defun dofor (var fortype varlist stmlist)
  (cond
    ((eq fortype 'in)
     `(prog (returnvar l1 l2)
	    (setq l2 ',varlist)
	 loop
	    (setq l1 (car l2))
	    (setq l2 (cdr l2))
	    (cond ((null l1) 
		   (return returnvar)))
	    (setq returnvar
		  ((lambda (,var)
		     ,@stmlist)
		   (l1)))
	    (go loop)))
    ((eq fortype 'on)
     `(prog (returnvar l1 l2)
	    (setq l2 ',varlist)
	 loop
	    (cond ((null l2) 
		   (return returnvar)))
	    (setq returnvar
		  ((lambda (,var)
		     ,@stmlist)
		   (l2)))
	    (setq l2 (cdr l2))
	    (go loop)))
    ((eq fortype 'rpt)
     `(prog (returnvar ,var)
	    (setq ,var 1)
	 loop
	    (cond ((not (> ,var ,varlist))
		   (setq returnvar ((lambda ()
				      ,@stmlist)))
		   (setq ,var (1+ ,var))
		   (go loop))
		  (t (return returnvar)))))
    (t  nil)))
;;;
;;; ucilisp let macro.
;;;
#+franz 
(eval-when (compile load eval)
  (defun uci_let1 (l vars vals body)
	 (cond ((null l)
		(cons (cons 'lambda (cons vars body)) vals))
	       (t
		(uci_let1 (cddr l)			
		      (cons (car l) vars) 
		      (cons (cadr l) vals) body)))))
#+franz 
(defun uci_let macro (l)
    (selfinsertmacro l
	(uci_let1 (cadr l) nil nil (cddr l))))

#+lispm
(eval-when (compile load eval)
(defun pairify (l);converts (a b c d ...... ) to ((a b)(c d) .....)
  (cond ((null l) nil)
	(t (cons (list (car l)(cadr l))(pairify (cddr l)))))))

#+lispm
    (eval-when (compile load eval)
    (defun uci_let macro (l)
       `(let
	  ,(pairify (cadr l))
	  ,@(cddr l);body of let
        )))

(defun nconc1 macro (l) (selfinsertmacro l
  `(nconc ,(cadr l) (list ,(caddr l)))))


;;;
;;; ucilisp selectq function. (written by jkf)
;;;
#+lispm (defun ct_selectq macro (l)
	    (selfinsertmacro l `(selectq . ,(cdr l))))
#+franz
(defun ct_selectq macro (form)
    (selfinsertmacro form
	 ((lambda (x)
		  `((lambda (,x)
			    (cond 
			     ,@(maplist 
				'(lambda (ff)
					 (cond ((memq (caar ff) '(otherwise t))
						`(t  . ,(cdar ff)))
					       ((atom (caar ff))
						`((eq ,x ',(caar ff))
						  . ,(cdar ff)))
					       (t
						`((memq ,x ',(caar ff))
						  . ,(cdar ff)))))
				(cddr form))))
		    ,(cadr form)))
	  (gensym 'Z))))

;;;
;;; ucilisp functions which declare read macros.
;;;
;;; dsm - declare splicing read macro.
;;;
;;;  DON'T USE THESE.  SEE CHARMAC for discussion about read macros.
;;;
(defun dsm macro (l)
  `(eval-when (compile load eval)
	      (setsyntax ',(cadr l) 'splicing ',(caddr l))))

;;;
;;; drm - declare read macro.
;;;
(defun drm macro (l) 
  `(eval-when (compile load eval)
	      (setsyntax ',(cadr l) 'macro ',(caddr l))))

;;; Fix stupid LMI bug: defsubst-with-parent defsubst's for some reason
;;; put (PROGN ...) around their output at macroexpand time.  Sigh.
;;; Soley 14 August 1985
(eval-when (eval compile load)

#-LMI (defmacro macro-expand-internal (form) `(macroexpand ,form))

#+LMI
(defun macro-expand-internal (form)
  (let ((answer (macroexpand form)))
    (if (and (listp answer) (eq (car answer) 'progn) (= (length answer) 2))
	(second answer)
      answer)))
)

;;;
;;;(%= a b) -> ucilisp assignment macro.
;;;
(defun %= macro (expression)
    (selfinsertmacro expression
	(uci_let (lft (macro-expand-internal (cadr expression)) rgt (caddr expression))
	    (cond ((atom lft) 
		      `(setq ,lft ,(subst lft '*_* rgt)))
		((get (car lft) 'set_program)
		    (cons (get (car lft) 'set_program)
			(append (cdr lft) (list (subst lft '*_* rgt)))))
		(t (ferror "no set program for ~A" (car lft)))))))
(defun assign macro (expression)
    (selfinsertmacro expression
	(uci_let (lft (macro-expand-internal (cadr expression)) rgt (caddr expression))
	    (cond ((atom lft) 
		      `(setq ,lft ,(subst lft '*_* rgt)))
		((get (car lft) 'set_program)
		    (cons (get (car lft) 'set_program)
			(append (cdr lft) (list (subst lft '*_* rgt)))))))))

(eval-when (compile load eval)  
  (defprop car rplaca set_program)
  (defprop cdr rplacd set_program)
  (defprop cadr ct_rplacad set_program)
  (defprop cddr ct_rplacdd set_program)
  (defprop caddr ct_rplacadd set_program)
  (defprop cadddr ct_rplacaddd set_program)
  (defprop caddddr ct_rplacadddd set_program)
  (defprop cadddddr ct_rplacaddddd set_program)
  (defprop caddddddr ct_rplacadddddd set_program)
  (defprop cadddddddr ct_rplacadddddddd set_program)
  (defprop cdddr ct_rplacddd set_program)
  (defprop cddddr ct_rplacdddd set_program)
  (defprop cdddddr ct_rplacddddd set_program)
  (defprop cddddddr ct_rplacdddddd set_program)
  (defprop cdddddddr ct_rplacddddddd set_program)
  (defprop funcall funcall_set_program set_program)
  (defprop aref aref_set_program set_program)
  
  #+franz
  (defprop cxr rplacx set_program)

  #+franz
  (defun funcall_set_program (arr index value)	  ; Only works for 1d arrays --
    (set (arrayref arr index) value))	  ; A real crock ++
  
  #+lispm
  (defun aref_set_program (arr index value)
    (aset value arr index))
  
  (defprop get get_set_program set_program)
  
  (defun get_set_program (atm prop val) 
    (putprop atm val prop))
  )

;;; WARNING: THESE ONLY WORK FOR 1D ARRAYS
(defun ct_aset (arr index value)
  #+lispm  (aset value arr index)
  #+franz  (cond ((arrayp arr) (set (arrayref arr index) value))
		 ((hunkp arr) (rplacx index arr value))))

(defun ct_aref (arr index)
#+lispm  (aref arr index)
#+franz  (cond ((arrayp arr) (funcall arr index))
	       ((hunkp arr) (cxr index arr))))

(defun ct_listarray (arr)
  #+lispm (listarray arr)
  #+franz (cond ((arrayp arr)
		 (putd 'crock_city arr)	  ; OF ALL THE BLETCHEROUS PHROGS!!!
		 ;; Franz listarray only works if the array is the fundef
		 ;; of the argument!!!
		 (listarray 'crock_city))
		((hunkp arr)
		 (do ((c 0 (1+ c))
		      (res nil (cons (cxr c arr) res)))
		     ((null (greaterp (hunksize arr) c)) (nreverse res))))))

(defun ct_rplacad (exp1 exp2) 
  (rplaca (cdr exp1) exp2))

(defun ct_rplacdd (exp1 exp2) 
  (rplacd (cdr exp1) exp2))

(defun ct_rplacadd (exp1 exp2) 
  (rplaca (cddr exp1) exp2))

(defun ct_rplacaddd (exp1 exp2) 
  (rplaca (cdddr exp1) exp2))

(defun ct_rplacadddd (exp1 exp2) 
  (rplaca (cddddr exp1) exp2))

(defun ct_rplacaddddd (exp1 exp2) 
  (rplaca (cdddddr exp1) exp2))

(defun ct_rplacadddddd (exp1 exp2) 
  (rplaca (cddddddr exp1) exp2))

(defun ct_rplacaddddddd (exp1 exp2) 
  (rplaca (cdddddddr exp1) exp2))

(defun ct_rplacddd (exp1 exp2) 
  (rplacd (cdddr exp1) exp2))

(defun ct_rplacdddd (exp1 exp2) 
  (rplacd (cdddr exp1) exp2))

(defun ct_rplacddddd (exp1 exp2) 
  (rplacd (cddddr exp1) exp2))

(defun ct_rplacdddddd (exp1 exp2) 
  (rplacd (cdddddr exp1) exp2))

(defun ct_rplacddddddd (exp1 exp2) 
  (rplacd (cddddddr exp1) exp2))

;;;
;;; ucilisp record_type package to declare records and field extraction
;;;	macros.
;;;severely hacked by Paul Robertson to work when compiled.(1-19-83)

;;; NB:  Caveat!!  Mark changed the LISTP's below to CONSP's.  15-May-83
;;; Pretty sure that's the intended semantics in all cases.  -- mlm
(defun record_type macro (l)
    (selfinsertmacro l
	(let ((*type* (cadr l)) (*flag* (caddr l)) (slots (car (last l))))
	    (uci_let (slotsandmacros (slot_funs_extract slots (and *flag*
								  '(d))))
	    `(progn 'compile
		 (defun ,*type*
		     ,(mapcar 'car slotsandmacros)
		     ,(cond ((null *flag*) (struc_cons_form slots))
			  (t (append `(cons ',*flag*)
				 (list (struc_cons_form slots))))))
		 ,@(mapcar 'cadr slotsandmacros)
		 ,(cond (*flag*
			    (cond ((consp *flag*) ;was listp
				   (setq *flag* *type*)))
			    `(defun ,(concat 'is_ *type*)
				 macro
				 (l)
				 (list 'and (list 'consp  ;was listp
						  (cadr l))
				     (list 'eq (list 'car (cadr l))
					 '',*flag*))))))))))

(eval-when (compile eval load)  
(defun slot_funs_extract (slots path)
  (cond ((null slots) nil)
	((atom slots)
	 (list (list slots
	      `(defun ,(concat *type* '% slots)
		    macro
		    (l)
		    (selfinsertmacro l
			(list ',(readlist `(c ,@path r))
			    (cadr l)))))
	))
	((nconc (slot_funs_extract (car slots) (cons 'a path))
		(slot_funs_extract (cdr slots) (cons 'd path))))))
  
(defun struc_cons_form (struc)
  (cond ((null struc) nil)
	((atom struc) struc)
	(t `(cons ,(struc_cons_form (car struc))
		  ,(struc_cons_form (cdr struc)))))))

;;;
;;; ucilisp record_type package to declare records and field extraction
;;;	macros.
;;;severely hacked by Paul Robertson to work when compiled.(1-19-83)
;;; Totally rewritten and defaced by pozsvath to make records into arrays
;;;	rather than LISTS!!! Yuck!
(declare (special *slot_count*))

;;; NB:  Caveat!!  Mark changed the LISTP's below to CONSP's.  15-May-83
;;; Pretty sure that's the intended semantics in all cases.  -- mlm
(defun record_type2 macro (l)
       (selfinsertmacro l
			(let ((*type* (cadr l)) (*flag* (caddr l))
			      (slots (car (last l))))
			  (setq *slot_count*
				(cond ((null *flag*) -1)
				      (t 0)))
			  (let 
			    ((slotsandmacros (slot_funs_extract2 slots)))
			    `(progn 'compile
				    (defun ,*type*
				      (&rest body)
				      (funcall 'list_to_array
					     ,(cond ((null *flag*) 'body)
						    (t `(cons ',*flag* body)))))
				    ,@(mapcar 'cadr slotsandmacros)
				    ,(cond
				       (*flag*
					(cond ((consp *flag*)	  ;was listp
					       (setq *flag* *type*)))
					`(defun ,(concat 'is_ *type*)
						macro
					   (l)
					   (list 'and
						 (list 'eq
						       (list 'typep
							     (cadr l))
						       ''array)
						 (list 'eq
						       #+franz
						       (list 'arraycall
							     t (cadr l) 0)
						       #+lispm
						       (list 'aref (cadr l) 0)
						       '',*flag*))))))))))

(eval-when (compile eval load)  
(defun slot_funs_extract2 (slots)
  (cond ((null slots) nil)
	((atom slots)
	 (setq *slot_count* (+ 1 *slot_count*))
	 (list
	   (list slots
		 `(defun ,(concat *type* '% slots)
			 macro
		    (l)
		    (selfinsertmacro l
				     #+franz
				     (list 'arraycall t (cadr l) ,*slot_count*)
				     #+lispm
				     (list 'aref (cadr l) ,*slot_count*))))
	   ))
	((nconc (slot_funs_extract2 (car slots))
		(slot_funs_extract2 (cdr slots)))))))

(defun list_to_array (l)
    (let ((res #+lispm (make-array  (length l));++pmj
	       #+franz (array nil t (length l)))
	     (count 0))
	(mapcar
	    #'(lambda (elem)
#+franz		  (set (arrayref res count) elem)
#+lispm           (aset elem res count)
		  (setq count (1+ count)))
	    l)
	res))

;;;
;;; ucilisp record_type package to declare records and field extract
;;;	macros.
;;;severely hacked by Paul Robertson to work when compiled.(1-19-83)
;;; Totally rewritten and defaced by pozsvath to make records into arrays
;;;	rather than LISTS!!! Yuck!
;;; Yet again rehacked and defaced and etc. by pozsvath to make records
;;;	hunks rather than arrays! 
(declare (special *slot_count*))

;;; NB:  Caveat!!  Mark changed the LISTP's below to CONSP's.  15-May-83
;;; Pretty sure that's the intended semantics in all cases.  -- mlm
(defun record_type3 macro (l)
#+franz
       (selfinsertmacro l
			(let ((*type* (cadr l)) (*flag* (caddr l))
			      (slots (car (last l))))
			  (setq *slot_count*
				(cond ((null *flag*) -1)
				      (t 0)))
			  (let 
			    ((slotsandmacros (slot_funs_extract3 slots)))
			    (cond ((consp *flag*) ;was listp
				   (setq *flag* *type*)))
			    `(progn 'compile
				    (defun ,*type*
				      (&rest body)
				      (funcall 'list_to_hunk
					       ,(cond ((null *flag*) 'body)
						      (t
						       `(cons ',*flag* body)))))
				    ,@(mapcar 'cadr slotsandmacros)
				    ,(cond
				      (*flag*
				       `(defun ,(concat 'is_ *type*)
					       macro
					  (l)
					  (list 'and
						(list 'hunkp (cadr l))
						(list 'eq
						      (list 'cxr 0 (cadr l))
						      '',*flag*)))))))))
#+lispm
	(macro-expand-internal (rplaca l 'record_type2)))

(eval-when (compile eval load)  
(defun slot_funs_extract3 (slots)
  (cond ((null slots) nil)
	((atom slots)
	 (setq *slot_count* (+ 1 *slot_count*))
	 (list (list slots
	      `(defun ,(concat *type* '% slots)
		    macro
		    (l)
		    (selfinsertmacro l
			(list 'cxr ,*slot_count* (cadr l)))))))
	((nconc (slot_funs_extract3 (car slots))
		(slot_funs_extract3 (cdr slots)))))))

#+franz
(defun list_to_hunk (l)
    (let ((res (makhunk (length l)))
	     (count 0))
	(mapcar
	    #'(lambda (elem)
	          (rplacx count res elem)
		  (setq count (1+ count)))
	    l)
	res))

;;;	YET ANOTHER RECORD_TYPE (this is getting ridiculous...)
;;; Allocates a piece of storage (hunk-franz; array-lm) from the 
;;; pure space.

(defun record_type4 macro (l)
       (selfinsertmacro l
			(let ((*type* (cadr l)) (*flag* (caddr l))
			      (slots (car (last l))))
			  (setq *slot_count*
				(cond ((null *flag*) -1)
				      (t 0)))
			  (let 
			    ((slotsandmacros (slot_funs_extract4 slots)))
			    (cond ((consp *flag*) ;was listp
				   (setq *flag* *type*)))
			    `(progn 'compile
				    (defun ,*type*
				      (&rest body)
				      (funcall 'list_to_record4
					       ,(cond ((null *flag*) 'body)
						      (t
						       `(cons ',*flag* body)))))
				    ,@(mapcar 'cadr slotsandmacros)
				    ,(cond
				       (*flag*
					`(defun ,(concat 'is_ *type*)
						macro
					   (l)
					   #+franz
					   (list 'and
						 (list 'hunkp (cadr l))
						 (list 'eq
						       (list 'cxr 0 (cadr l))
						       '',*flag*))
					   #+lispm
					   (list 'and
						 (list 'eq
						       (list 'typep (cadr l))
						       ''array)
						 (list 'eq
						       (list 'aref (cadr l) 0)
						       '',*flag*))))))))))

(eval-when (compile eval load)  
(defun slot_funs_extract4 (slots)
  (cond ((null slots) nil)
	((atom slots)
	 (setq *slot_count* (+ 1 *slot_count*))
	 (list
	   (list slots
		 `(defun ,(concat *type* '% slots)
			 macro
		    (l)
		    (selfinsertmacro l
				     #+franz
				     (list 'cxr ,*slot_count* (cadr l))
				     #+lispm
				     (list 'aref (cadr l) ,*slot_count*)
				     )))
	   ))
	((nconc (slot_funs_extract4 (car slots))
		(slot_funs_extract4 (cdr slots)))))))

;;;  load polly to get pure-* functions
;(eval-when (compile load eval) (ct_load 'polly))  ;; Purespace hacks


(defun list_to_record4 (l)
    (let ((res (#+franz pure-makhunk #+lispm pure-make-array (length l)))
	     (count 0))
	(mapcar
	    #'(lambda (elem)
#+franz	          (rplacx count res elem)
#+lispm           (aset elem res count)
			  (setq count (1+ count)))
	    l)
	res))

;;;A new C*T record type definer. Main differences are:
;;; --subst used instead of macros
;;; --meta point works on all constructor, accesor and predicate functions
;;; --cdr-coded lists are used
;;; wab 6-20-85
#+lispm
(defmacro def_record_type (name &rest flag-slots)
  (let ((arg-length (length flag-slots)) indicator slots)
    (cond ((eq arg-length 1.)
	   (setq indicator name
		 slots (car flag-slots)))
	  ((eq arg-length 2.)
	   (setq indicator (car flag-slots)
		 slots (cadr flag-slots)))
	  (t (error '"Bad ct record type")))
    `(progn 'compile
	    (record-source-file-name ',name 'def_record_type)
	    (defsubst ,name ,(drt_slot_list_extract slots)
	      ,(cond (indicator (drt_struc_cons_form `(',indicator ,@slots)))
		     (t (drt_struc_cons_form slots))))
	    ,@(drt_slot_funs_extract name slots (and indicator '(d)))
	    ,(cond (indicator
		    `(#+Symbolics sys:defsubst-with-parent
		      #+LMI        si:defsubst-with-parent ,(concat 'is_ name)
					       (,name def_record_type)
					       (record)
		       (and (consp record)
			    (eq (car record) ',indicator))))))))

#+lispm
(eval-when (compile eval load) 
  (defprop def_record_type "C*T record" si:definition-type-name)
  
  (defun drt_slot_list_extract (slots)
    (cond ((null slots) nil)
	  ((atom slots) (list slots))
	  (t (nconc (drt_slot_list_extract (car slots))
		    (drt_slot_list_extract (cdr slots))))))
  
  (defun drt_slot_funs_extract (base-name slots path)
    (cond ((null slots) nil)
	  ((atom slots)
	   (list `(#+Symbolics sys:defsubst-with-parent
		   #+LMI        si:defsubst-with-parent,(concat base-name '% slots)
					    (,base-name def_record_type)
					    (record)
		    (,(readlist `(c ,@path r)) record))))	;watch of package problems
	  (t (nconc (drt_slot_funs_extract base-name (car slots) (cons 'a path))
		    (drt_slot_funs_extract base-name (cdr slots) (cons 'd path))))))
  
  (defun drt_struc_cons_form (struc &aux last_cdr)
    (cond ((null struc) nil)
	  ((or (atom struc)
	       (and (eq (length struc) 2) (eq (first struc) 'quote)))
	   struc)
	  ((setq last_cdr (cdr (last struc)))
	   `(list* ,@(mapcar #'drt_struc_cons_form (firstn (length struc) struc))
		   ,(drt_struc_cons_form last_cdr)))
	  (t `(list ,@(mapcar #'drt_struc_cons_form struc))))))

;;; usage : (some list predict)
;;;
#+franz 
(defun some macro (l)
    (selfinsertmacro l
	`((lambda (a f)
	      (prog ()
		  loop
		  (cond ((null a) (return nil))
		      ((funcall f (car a))
			  (return a))
		      (t (setq a (cdr a))
			  (go loop)))))
	     ,(cadr l)
	     ,(caddr l)
	     )))

  
(defun aip_for macro (*l*)
  (selfinsertmacro
  *l*
  (uci_let (vars (vars%for *l*)
	     args (args%for *l*)
	     test (test%for *l*)
	     type (type%for *l*)
	     body (body%for *l*))
       (cons (make_mapfn vars test type body)
	     (cons (list 'quote
			 (make_lambda 
			  vars (add_test test
					 (make_body vars test type body))))
		   args)))))
  
(defun uci_error (l x)
  (cond (x (ct_terpri) (ct_princ l) (ct_terpri) (break) l)
	(t l)))
  
(eval-when (eval load compile)
(defun type%for (*l*)
  (uci_let (item (item%for '(do save splice filter) *l*))
       (cond (item (car item))
	     ((error '"No body in for loop")))))
  
(defun vars%for (*m*)
  (mapcan '(lambda (x) (cond ((is_var_form x) (list (var%var_form x))))) *m*))

(defun args%for (*n*)
  (mapcan '(lambda (x) 
		   (cond ((is_var_form x) (list (args%var_form x)))))
	  *n*))

(defun is_var_form (x) (and (listp x) (eq (length x) 3) (eq (cadr x) 'in)))
  
(defun var%var_form (x) (car x))

(defun args%var_form (x) (caddr x))
  
(defun test%for (*o*)
  (uci_let (item (item%for '(when) *o*))
       (cond (item (cadr item)))))
  
(defun body%for (*p*)
  (uci_let (item (item%for '(do save splice filter) *p*))
       (cond ((not item) (error '"NO body in for loop"))
	     ((eq (length (cdr item)) 1) (cadr item))
	     ((cons 'progn (cdr item))))))

(defun item%for (keywords *l*)
  (uci_let (item nil)
       (some keywords
	     '(lambda (key) (setq item (assoc key (cdr *l*)))))
       item))

(defun make_mapfn (vars test type body)
  (cond ((equal type 'do) 'mapc)
	((not (equal type 'save)) 'mapcan)
	((null test) 'mapcar)
	((subset_test vars body) 'subset)
	('mapcan)))
  
(defun subset_test (vars body)
  (and (equal (length vars) 1) (equal (car vars) body)))
  
(defun make_body (vars test type body)
  (cond ((equal type 'filter)
	 (list 'uci_let (list 'x body) '(cond (x (list x)))))
	((or (not (equal type 'save)) (null test)) body)
	((subset_test vars body) nil)
	((list 'list body))))
  
(defun add_test (test body)
  (cond ((null test) body)
	((null body) test)
	(t (list 'cond (cond ((eq (car body) 'progn) (cons test (cdr body)))
			     ((list test body)))))))
  
(defun make_lambda (var body)
  (cond ((equal var (cdr body)) (car body))
	((eq (car body) 'progn) (cons 'lambda (cons vars (cdr body))))
	((list 'lambda vars body)))))


(defun ct_pop macro (q)
    (selfinsertmacro q
	`(prog1
	     (car ,(cadr q))
	     (%= ,(cadr q) (cdr ,(cadr q)))
	 )
    ))

;#+oldfranz			; appeared with maryland flavors
;(defun length (*u*)
;  (cond ((null *u*) 0)
;	((atom *u*) 0)
;	((add1 (length (cdr *u*))))))
  
#+franz 
(defun every macro (l)
    (selfinsertmacro l
	`(prog ($$k $v)
	     (setq $$k ,(caddr l))
	     loop
	     (cond ((null $$k)
		       (return t))
		 ((apply ,(cadr l) (list (car $$k)))
		     (setq $$k (cdr $$k))
		     (go loop)))
	     (return nil))))

(defun timer fexpr (request)
  (prog (timein timeout result cpu garbage)
	(setq timein (time))
	(prog ()
	      loop (setq result (eval (car request)))
	      (setq request (cdr request))
	      (cond ((null request) (return result))
		    ((go loop))))
	(setq timeout (time))
	(setq cpu (quotient (times 1000.0
				   (quotient (difference (car timeout) 
							 (car timein))
					     60.0))
			    1000.0))
	(setq garbage (quotient (times 1000.0
				       (quotient (difference (cadr timeout) 
							     (cadr timein)) 
						 60.0))
				1000.0))
	(ct_print (cons cpu garbage))
	(ct_terpri)
	(return result)))
  
(defun addprop (id value prop)
  (putprop id (enter value (get id prop)) prop))
  
(defun enter (v l)
  (cond ((member v l) l)
	(t (cons v l))))
#+franz 
(defmacro subset (fun lis)
  `(mapcan '(lambda (ele)
		    (cond ((funcall ,fun ele) (ncons ele))))
	   ,lis))

;(defun push macro (body)
;    (selfinsertmacro body
;        `((lambda(stk)
;	     (setq stk (cons ,(cadr body) stk)))
;	  ,(caddr body)))))

(defun ct_push macro (valvar)
    (selfinsertmacro valvar
	`(%= ,(caddr valvar)
	     (cons ,(cadr valvar)
		   ,(caddr valvar)))))

(defun uci_push macro (varval);same as lispm push except args reversed.
  `(push ,(caddr varval)(cadr varval)))

(defun prelist (a b)
  (cond ((null a) nil)
	((eq b 0) nil)
	((cons (car a) (prelist (cdr a) (sub1 b))))))
  
(defun suflist (a b)
  (cond ((null a) nil)
	((eq b 0) a)
	((suflist (cdr a) (sub1 b)))))
  
(defun uci_loop macro (l)
    (selfinsertmacro l
	`(prog ,(var_list (get_keyword 'initial l))
	     ,@(subset (function caddr)
		   (setq_steps (get_keyword 'initial l)))
	     loop
	     ,@(apply (function append) (mapcar (function do_clause) (cdr l)))
	     (go loop)
	     exit
	     (return ,@(get_keyword 'result l)))))
  
(defun do_clause (clause)
  (cond ((memq (car clause) '(initial result)) nil)
	((eq (car clause) 'while)
	 (list (list 'or (cadr clause) '(go exit))))
	((eq (car clause) 'do) (cdr clause))
	((eq (car clause) 'next) (setq_steps (cdr clause)))
	((eq (car clause) 'until)
	 (list (list 'and (cadr clause) '(go exit))))
	(t (ct_terpri) (ct_princ '"unknown keyword clause")
	   (ct_print (car clause))
	   (ct_terpri))))
  
(defun get_keyword (key l)
  (cdr (assoc key (cdr l))))
  
(defun var_list (r)
  (and r (cons (car r) (var_list (cddr r)))))
  
(defun setq_steps (s)
  (and s (cons (list 'setq (car s) (cadr s))
	       (setq_steps (cddr s)))))
#+franz 
(putd 'readch (getd 'readc)) ;;++


;;;
;;; ucilisp msg function. (written by jkf)
;;;
;;;  This version originally existed in NEITHER dialect.  Then, with
;;; the maryland flavors release, it was added to Franz.  Now, we 
;;; add it to Zetalisp.
;;;
;;;  DON'T USE THIS!!! IT IS UNSUPPORTED AT CT.  
;;;      THIS HAS NOT BEEN TESTED.
;;;  (You might want to look at FORMAT, which is more powerful,
;;;  tested, and well documented in the LISPM manual.)
;;;
#+lispm		; suddenly appeared with the maryland
				; flavors.
(defun msg macro (call)
    (selfinsertmacro call
	`(progn ,@(mapcar 
		      '(lambda (form)
			   (cond ((eq form t) '(line_feed 1))
			       ((numberp form)
				   (cond ((greaterp form 0) 
					     `(msg_space ,form))
				       (t `(line_feed ,(minus form)))))
			       ((atom form) `(ct_princ ,form))
			       ((eq (car form) t) '(ct_princ "	"))	  ;tab
			       ((eq (car form) 'e) 
				   `(ct_princ ,(cadr form)))
			       (t `(ct_princ ,form))))
		      (caddr call)))))
  
;;;
;;; this must be fixed to not use do.   THIS IS ALSO UNTESTED.  Foo.
;;;
(defun msg_space macro (n)
    (selfinsertmacro n
	(cond ((eq 1 (cadr n)) '(ct_princ '" "))
	    (t `(uci_do i ,(cadr n) (sub1 i) (lessp i 1) (ct_princ '" "))))))

;;;  used by msg, above.
(defun line_feed macro (n)
    (selfinsertmacro n
	(cond ((eq 1 (cadr n)) '(terpr))
	    (t `(uci_do i ,(cadr n) (sub1 i) (lessp i 1) (terpr))))))

;;; compatability functions: functions required by uci lisp but not
;;;	present in franz
;;;

(defun uci_union n
	 (do ((res (arg n))
	      (i (sub1 n) (sub1 i)))
	     ((zerop i) res)
	     (mapc '(lambda (arg)
			    (cond ((not (member arg res)) 
				   (setq res (cons arg res)))))
		   (arg i))))

#+franz 
(putd 'newsym (getd 'gensym))	; this is not exactly correct.
#+franz 			; it only uses the first letter of the arg.
(putd 'remove (getd 'delete))

;(defun newsym ()(gensym))

(defun sprint (form column)
  ;;; Column arg is ignored for now.
  (progn column (grind-top-level form)))

(defun save (f) (putprop f (fsymeval f) 'olddef))

(defun unsave (f) (fset f (get f 'olddef)))

(fset 'atcat (fsymeval 'concat))


;#+oldfranz 			; appeared with the maryland flavors
;(defun neq macro (x)
;    (selfinsertmacro x
;	`(not (eq ,@(cdr x)))))

#+Franz (fset 'gt (fsymeval '>))
#+Franz (fset 'lt (fsymeval '<))

#+Lispm
(defmacro gt (x) `(> ,x))

#+Lispm
(defmacro lt (x) `(< ,x))

(defun le macro (x)
    (selfinsertmacro x
	`(not (> ,@(cdr x)))))

(defun ge macro (x)
    (selfinsertmacro x
	`(not (< ,@(cdr x)))))

(defun litatom macro (x)
    (selfinsertmacro x
	`(and (atom ,@(cdr x))
	     (not (numberp ,@(cdr x))))))

;;;  This appeared in Franz Lisp with the Maryland release, and does
;;; not exist in bare Zetalisp, so we add it to the lisp machine now.
#+lispm		
(defun tconc (ptr x)
  (cond ((null ptr)
	 (prog (temp)
	       (setq temp (list x))
	       (return (setq ptr (cons temp (last temp))))))
	((null (car ptr))
	 (rplaca ptr (list x))
	 (rplacd ptr (last (car ptr)))
	 ptr)
	(t (prog (temp)
		 (setq temp (cdr ptr))
		 (rplacd (cdr ptr) (list x))
		 (rplacd ptr (cdr temp))
		 (return ptr)))))

;(fset 'dddd* (fsymeval 'boundp))
;(defun boundp (l)     ;where dd this come from?
;  (cond ((arrayp l))
;	((dddd* l))))

;;; Written be Paul Robertson.
;;; Copyright (C) Computer * Thought Corporation.

;;; Hash function code from AIP, xlated into maclisp. and slightly extended.

(eval-when (compile  load)    
(defun init_hash_table (n)	; initialize hash table of given size.
    (%= *table_size*  n)
    #+franz (array harray t *table_size*)
    #+lispm (setq harray (make-array *table_size*));++pmj
))
;; This is in for references such as (harray i)
#-franz
(defmacro harray (index) (list 'aref 'harray index))

(eval-when (compile load eval)
  #+lispm (def_record_type asocn nil (lkey rkey val))
  #+franz (record_type asocn nil (lkey rkey val)))

(defun pput (k1 k2 k2h v)
    (uci_let (i (phash k1 k2 k2h) a nil)
	(%= a (passn i k1 k2 k2h))
	(cond (a (%= (asocn%val a) v))
	      (t #+franz(store (harray i) (cons (asocn k1 k2 v) (harray i)))
		 #+lispm (aset (cons (asocn k1 k2 v) (harray i)) harray i));++pmj
	)
    )
)

(defun pget (k1 k2 k2h)
    (uci_let (a (passn (phash k1 k2 k2h) k1 k2 k2h))
	(cond (a (asocn%val a))
	)
    )
)

(defun prem (k1 k2 k2h)
    (uci_let (i (phash k1 k2 k2h) a nil)
	(%= a (passn i k1 k2 k2h))
	(cond (a #+franz(store (harray i) (dremove a (harray i)))
		 #+lispm(aset (dremove a (harray i)) harray i));++pmj
	)
    )
)

(defun dremove (thisfrom that)	; removes occurences of thisfrom that
    (cond
	((null that) nil)
	((eq thisfrom (car that)) (dremove thisfrom (cdr that)))
	(t (rplacd that (dremove thisfrom (cdr that))))))

(defun phash (k1 k2 k2h)
    (remainder 
	(plus
	    (sxhash k1)
	    (cond ((numberp k2h) k2h) (t (sxhash k2))))
	*table_size*)
)

(defun findmatch (a)
    (and (eq (asocn%lkey a) sk1)
         (or (eq (asocn%rkey a) sk2) 
	     (equal sk2 (asocn%rkey a))))
)

(defun passn (i sk1 sk2 sk2h)
    (car (some (harray i)  'findmatch)))

(defun create_hash_table (name)
    (eval `(defun ,(concat 'put_ name) macro (l)
	       (selfinsertmacro l
		   (list 'pput '',name (cadr l)
		       (cond 
			   ((cdddr l) (caddr l))
			   (t nil))
		       (car (last l))))))
    (eval `(defun ,(concat 'get_ name) macro (l)
	       (selfinsertmacro l
		   (list 'pget '',name (cadr l)
		       (cond ((cddr l) (caddr l))(t nil))))))
    (eval `(defun ,(concat 'rem_ name) macro (l)
	       (selfinsertmacro l
		   (list 'prem '',name (cadr l)
		       (cond ((cddr l) (caddr l))(t nil)))))))

; a defconst macro similar to the one on the LM.
; code provided by M.Miller
#+franz
(defun defconst macro (form)
       (selfinsertmacro form
             `(progn 'compile (declare (special ,(cadr form)))
                              (setq ,(cadr form) ,(caddr form))
                     (defprop ,(cadr form) ,(cadddr form) documentation))))

(defun ct_listp macro (form)
       (selfinsertmacro form
			#+franz `(listp ,@(cdr form))
			;;; Next has to bind it to prevent double eval.
			#+lispm `(let ((frob ,(cadr form)))
				   (or (null frob) (listp frob)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; these four functions used to be in stdenv.l and then diana.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; these  macros will be replaced by mapping add_name over a list.
       ;;;;;
(defun uplow(ch)
       ;;;;;

  (cond ((and (> ch 64.)(< ch 91.))(+ ch 32))
	(t ch)) 
)
       ;;;;;;;;;
(defun uplowlist(l)
       ;;;;;;;;;

  (mapcar (function uplow) l))
       ;;;;;
(defun lowup(ch)
       ;;;;;

  (cond ((and (> ch 96.)(< ch 123.))(- ch 32));++
	(t ch)) 
)
       ;;;;;;;;;
(defun lowuplist(l)
       ;;;;;;;;;

  (mapcar (function lowup) l))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

;;; The following Kludge is to fix a bug in compiled Franz. -- mlm, pr.
#+franz
(putd 'si:xr-bq-cons (getd 'cons))

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;