;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT CPTFONTB) -*-

1;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.

;;;  Zetalisp support package.  Zetalisp functions that are not considered
;;;  to be Common Lisp extensions live here (currently, some Zetalisp functions
;;;  are scattered throughout the Kernel as well).  Also, the incompatible 
;;;  functions that are not defined elsewhere in the Kernel live here.*

;;;   5/02/89 JLM  Added DBG command 
;;;   04/10/89 jlm Change GLOBALIZE-1 to use (SETF (GET ... instead of (PUTPROP ... 
;;;   05/09/89 clm Removed DBG command.
;;;   05/10/89 jlm put it back using cerror instead of cleh:break
1;;;  Package support*

;;AB 8/3/87.  Fix arglist to show FILE-ALIST arg.
(defmacro zlc:package-declare (&rest declaration)
  "Define a package.  The BODY is used to intern or shadow symbols.
If SUPERIOR-NAME is non-nil, the new package will use SUPERIOR-NAME 
and all the packages SUPERIOR-NAME uses.  In addition, the SUPERIOR-NAME 
package will be made auto-exporting.  SIZE is the package's initial
size.  FILE-ALIST is an obsolete argument and must be NIL.
  PACKAGE-DECLARE is obsolete; MAKE-PACKAGE should be used instead."
  (declare (arglist &quote package-name superior-name size file-alist &rest body))
  `(eval-when (compile load eval)
     (pkg-process-declaration ',declaration)))


;;AB 8/3/87.  Fix zlc:PACKAGE-DECLARE when the package already exists and needs to be rehashed. [SPR 6060]
;;            Fix so using GLOBAL just uses GLOBAL (not "LISP" "TICL" "ZLC"). [SPR 5224]
(defun pkg-process-declaration (declaration &aux name super size file-alist body tem	
					    (*package* *package*)
					    ;Make sure nothing happens while rehashing, etc.
					    (inhibit-scheduling-flag t))
    (setq name (first declaration)
	  super (if (second declaration)
		    (cond ((string-equal (second declaration) "NONE") nil)
			  (t (pkg-find-package (second declaration))))
		  '("LISP" "TICL" "ZLC"))
	  size (or (third declaration) 1000.)
	  file-alist (fourth declaration)
	  body (cddddr declaration))
    ;; Look for any existing package with the same name and superior,
    ;; and if there is one make this declaration apply to it
    ;; (and make it larger if it isn't as large as this decl says).
    ;; Otherwise, create a package.
    (if (setq tem (find-package name))
	(setq *package* (cond ((>= (pack-max-number-of-symbols tem) size)
			       tem)
			      (t
			       (package-rehash tem size)
			       tem)))	;ab
      (setq *package* (make-package name
				    :use (if (packagep super)
					     (progn
					       (setf (pack-after-intern-daemon super) 'externalize-all-symbols)
					       (setf (pack-auto-export-p super) t)
					       (cons super
						     (package-use-list super)))
					     (progn
					       (mapc #'(lambda (pkg)
							 (with-package-object (pkg)
							   (setf (pack-after-intern-daemon pkg) 'externalize-all-symbols)
							   (setf (pack-auto-export-p pkg) t)))
						     super)
					       super))
				    :size size)))
    (when file-alist
      (ferror nil "Non-null file-alist in declaration of package ~A.  Use the SYSTEM facility." *package*))
    ;; Process the body only if this is the first time this package is declared.
    (unless (getf (pack-plist *package*) 'declared-p)
	   (dolist (elt body)
	     (selector (car elt) string-equal
	       ("SHADOW" (shadow (cdr elt)))
	       ("EXTERNAL" nil)
	       ("INTERN"
		(dolist (str (cdr elt))
		  (intern (string str))))
	       ("BORROW"
		(let ((otherpkg (pkg-find-package (cadr elt))))
		  (dolist (str (cddr elt))
		    (intern-local (find-symbol (string str) otherpkg)))))
	       (t (ferror nil "~S no longer supported in PACKAGE-DECLARE."
			  (car elt)))))
	   (setf (getf (pack-plist *package*) 'declared-p) t)))

;;;  This should perhaps be moved to the PACKAGES file when we are ready to allow it.
;;CLM for PHD 9/02/87  Fixed so that intern-local returns the symbol with its package 
;;prefix.
(defun intern-local (sym &optional pkg)
  "Like INTERN but does not search any packages used by the package PKG.
If no symbol is found in PKG, SYM is interned in PKG, even if a package
used by PKG contains a matching symbol."
  (declare (values symbol already-interned-flag actual-package))
  (CHECK-TYPE sym (or string symbol) "a string or a symbol")
  (let ((pkg (cond ((null pkg) *package*)
		   ((not (packagep pkg)) (pkg-find-package pkg))
		   (t pkg))))
    (multiple-value-bind (symb type third)
	(find-symbol sym pkg)
      (if (or (null symb)
	      (eq type :inherited))
	    (let ((sym (cond ((symbolp sym) (copy-symbol sym))
			     ((stringp sym) (make-symbol sym t)))))
	      (return-from intern-local (intern-symbol-locally sym pkg) nil pkg))
	  (values symb type third)))))

(deff zlc:intern-soft #'find-symbol)

(setf (documentation 'zlc:intern-soft)
      "INTERN-SOFT searches for a symbol with the print name <string> ACCESSIBLE in package <pkg>.
The search begins with <pkg> itself.  If such a symbol is found, it is returned.  Otherwise,
each package USEd by <pkg> is searched for an EXTERNAL symbol with print name <string> until
either such a symbol is found, in which case it is returned, or all USEd packages have been 
searched, in which case NIL is returned.

INTERN-SOFT returns three values, the symbol found, an indicator keyword which is:
  :EXTERNAL - if the symbol is present in <pkg> and an external symbol of <pkg>
  :INTERNAL - if the symbol is present in <pkg> and not external
  :INHERITED - if the symbol is inherited by <pkg> from some package it USEs
  NIL - if the symbol is not accessible in <pkg>,
and the package in which the symbol found is present.

INTERN-SOFT never creates a new symbol nor has any side-effects on <pkg> (cf. INTERN).")

(defvar zlc:*all-packages* :unbound
  "Use the function LIST-ALL-PACKAGES to obtain a list of all packages that exist.")

(defun zlc:pkg-create-package (name &optional (super *package*) (size 200))
  "Create a new package named NAME.  If SUPER is non-nil, the new 
package will use SUPER and all the packages SUPER uses.  In addition, 
the SUPER package will be made auto-exporting.  This function is
obsolete - MAKE-PACKAGE should be used instead."
  (make-package name
		:size size
		:use (when super
		       (setq super (find-package super))
		       (setf (pack-after-intern-daemon super) 'externalize-all-symbols)
		       (setf (pack-auto-export-p super) t)
		       (cons super
			     (package-use-list super)))))
				    
(compiler:make-obsolete zlc:pkg-create-package make-package)

(eval-when (compile)
  (defmacro when-symbol-is-present ((pkg string hashcode word1 word0 &optional (index (gensym))) &body body)
;; This macro expands into code which searches for a symbol in <pkg> whose name matches <string>. 
;; In the event a candidate symbol is located, words 0 and 1 of its symbol table entry are placed
;; into <word0> and <word1> respectively and the forms in <body> are executed.
    `(let* ((symtab (pack-symbol-table ,pkg))
	    (length (p-number-of-entries symtab))
	    ,word0 ,word1)
       (do ((,index (rem ,hashcode length)))
	   (())
	 ;; Exit will occur when an entry with a null word0 is encountered or 
	 ;; possibly by code executed within <body>.
	 (if (setq ,word0 (p-word0 symtab ,index)) 
	     (progn
	       (when (and
		       (p-active-entry ,word0)
		       (= ,hashcode (p-extract-code ,word0))
		       (equal ,string		;Case-sensitive, font-sensitive comparison.
			      (symbol-name (setq ,word1 (p-word1 symtab ,index)))))
		 ,@body
		 (return))
	       (incf ,index)   
	       (when (>= ,index length) (setq ,index 0)))
	     (return))				;Else word0 is Nil -- terminate search.
	 )))
  (defmacro parse-pkg-argument (pkg)
    `(cond ((null ,pkg) *package*)
	   ((find-package ,pkg))1   *
	   (t (package-does-not-exist-error ,pkg))))
  (defmacro parse-str-argument (string)
    `(if (stringp ,string)
	 (if (eq (array-type ,string) art-fat-string)  
	     (string-remove-fonts ,string)
	     ,string)
	 (string ,string)))
  (defmacro sym-string-to-hash (string)
    `(sys:%sxhash-string ,string #xff))
  (defmacro del-shadowing-symbol (symbol pkg)
    `(let ((default-cons-area pkg-area))
       (setf (pack-shadowing-symbols ,pkg) (delete ,symbol (the list (pack-shadowing-symbols ,pkg)))))))

(defun zlc:intern-local-soft (str &optional pkg)
  (let* ((pkg (parse-pkg-argument pkg))
	 (str (parse-str-argument str))
	 (hashcode (sym-string-to-hash str)))
    (without-interrupts
      (when-symbol-is-present (pkg str hashcode entry-symbol entry-info)  
			      (return-from zlc:intern-local-soft
				(values entry-symbol
					(if (p-external-symbol entry-info) :external :internal)
					pkg))))))

(defun zlc:remob (symbol &optional (pkg (symbol-package symbol)) force-flag)
  "Removes (uninterns) SYMBOL from package PKG which defaults to the
contents of SYMBOL's package cell.  Uninterning may uncover a name
conflict if SYMBOL resides on the shadowing symbols list of PKG.
If FORCE-FLAG is T, REMOB does not look for name conflicts.
REMOB returns T if SYMBOL was uninterned and NIL otherwise."
  (if force-flag
      (progn  (check-type symbol symbol "a symbol")
	      (or (packagep pkg) (setq pkg (pkg-find-package pkg)))
	      (when (member symbol (pack-shadowing-symbols pkg) :test #'eq)
		(del-shadowing-symbol symbol pkg))
	      (let* ((string (symbol-name symbol))
		     (hashcode (sym-string-to-hash string)))
		(when-symbol-is-present (pkg string hashcode word0 word1 index)
					(setf (p-word0 symtab index) t)
					(setf (p-word1 symtab index) nil)
					(when (eq (symbol-package symbol) pkg)
					  (setf (symbol-package symbol) nil))
					(return-from zlc:remob t))))
      (unintern symbol pkg)))

(deff zlc:pkg-name 'package-name)
(deff zlc:pkg-kill 'kill-package)

(defun zlc:globalize (string
		      &optional into-package 
		      &aux globalize-fn-pkg globalize-val-pkg sym already-shadowed-symbols install-in-global-and-zlc)
  "Intern STRING in INTO-PACKAGE and forward all symbols with the
same symbol-name as STRING in INTO-PACKAGE and packages that use 
INTO-PACKAGE.  The forwarded symbols effectively become one symbol,
although they are not EQ to each other."
  (if into-package
      (setq into-package (pkg-find-package into-package))
      (progn (setq into-package *global-package*)
	     (setq install-in-global-and-zlc t)))
  (dolist (p (pack-used-by-list into-package))
    (let (tem)
      (if (setq tem (find-symbol string p))
	  (if (member tem (pack-shadowing-symbols p) :test #'eq)
	      (push tem already-shadowed-symbols)
	      (pushnew tem (pack-shadowing-symbols p))))))
  (setq sym (intern string into-package))
  (globalize-1 sym into-package already-shadowed-symbols globalize-val-pkg globalize-fn-pkg)
  (dolist (pack (pack-used-by-list into-package) t)
    (globalize-1 sym pack already-shadowed-symbols globalize-val-pkg globalize-fn-pkg)) 
  (export sym into-package)
  (when install-in-global-and-zlc
    (export sym *zlc-package*))
  (setf (symbol-package sym) into-package))

(defun globalize-1 (globalized-sym pkg already-shadowed-symbols globalize-val-pkg globalize-fn-pkg &aux local-sym)
  (cond ((and (setq local-sym (find-symbol globalized-sym pkg))
	      (neq local-sym globalized-sym)
	      (not (member local-sym already-shadowed-symbols :test #'eq))
	      (/= (%p-ldb-offset %%q-data-type local-sym 3) dtp-one-q-forward))
	 (cond ((boundp local-sym)
		(and (boundp globalized-sym)
		     (neq (symbol-value local-sym) (symbol-value globalized-sym))
		     (ferror nil "Multiple values for ~s, in ~a and ~a"
			     globalized-sym (symbol-package globalized-sym) (symbol-package local-sym)))
		(setq globalize-val-pkg pkg)
		(set globalized-sym (symbol-value local-sym))))
	 (cond ((fboundp local-sym)
		(and (fboundp globalized-sym)
		     (neq (symbol-function local-sym) (symbol-function globalized-sym))
		     (ferror nil "Multiple function definitions for ~s, in ~a and ~a"
			     globalized-sym (symbol-package globalized-sym) (symbol-package local-sym)))
		(setq globalize-fn-pkg pkg)
		(fset globalized-sym (symbol-function local-sym))))
	 (do ((plist (symbol-plist local-sym) (cddr plist)))
	     ((null plist))
	   (and (get globalized-sym (car plist))
		(neq (get globalized-sym (car plist)) (cadr plist))
		(ferror nil "Multiple values for ~s property of ~s" (car plist) globalized-sym))
	   ;(putprop globalized-sym (cadr plist) (car plist))	; jlm 4/11/89
	   (setf (get globalized-sym (car plist)) (cadr plist)))
	 (do ((i 1 (1+ i)))
	     ((= i 5))
	     (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative local-sym i)
				       dtp-one-q-forward
				       (%make-pointer-offset dtp-locative globalized-sym i))))))

1;;;  Hash support*

;; JK - Fix [SPR 4700].
;;AB 8-05-87.  o  Un-support :ACTUAL-SIZE arg.  The actual size MUST be forced to prime. [SPR 6037]
(defun zlc:make-equal-hash-table (&rest options)
  "Creates and returns a new hash table like MAKE-HASH-TABLE
except that keys are by default compared using EQUAL."
  (declare
    (arglist &key size rehash-size rehash-threshold &extension compare-function
	     hash-function area number-of-values rehash-function funcallable-p))
  (LET ((tem (MEMBER :actual-size options :test #'EQ)))
    (WHEN tem (SETF (CAR tem) :size)))
  (apply 'make-hash-array
         (cond ((and (member :compare-function options :test #'eq)
		     (member :hash-function options :test #'eq))
		options)
	       ((member :compare-function options :test #'eq)
		(append '(:hash-function equal-hash) options))
	       ((member :hash-function options :test #'eq)
		(append '(:compare-function equal) options))
	       (t (append '(:test equal) options)))))

(deff zlc:clrhash-equal 'clrhash)
(deff zlc:gethash-equal 'gethash)
(deff zlc:puthash-equal 'puthash)
(deff zlc:remhash-equal 'remhash)
(deff zlc:swaphash-equal 'swaphash)
(deff zlc:maphash-equal 'maphash)
(deff zlc:maphash-equal-return 'maphash-return)

1;;;  Incompatible functions*

(defun zlc:union (&rest lists)
  "Return the union of any number of lists, regarded as sets.
Each element of any of the arguments is also an element of the value.
If the first argument has no duplicate elements, neither does the value.
Elements are compared with EQ."
  (cond ((null lists) nil)
	((null (cdr lists)) (car lists))
	(t (apply 'zlc:nunion (copy-list (car lists)) (cdr lists)))))

(defun zlc:nunion (&rest lists &aux accum)
  "Alter the first argument so that it becomes the union of all the arguments.
Compares elements with EQ."
  (setq accum (car lists))
  (let ((tail (or (last accum) (variable-location accum))))
    (do ((ls (cdr lists) (cdr ls))) ((null ls))
	(do ((l (car ls) (cdr l))) ((null l))
	    (or (member (car l) accum :test #'eq)
		(rplacd tail (setq tail (cons (car l) nil)))))))
  accum)

(defun zlc:intersection (&rest lists)
  "Return the intersection of any number of lists, regarded as sets.
If the first argument contains no duplicate elements, neither does the value.
Compares elements with EQ."
  (cond ((null lists) nil)
	((null (cdr lists)) (car lists))
	(t (apply 'zlc:nintersection (copy-list (car lists)) (cdr lists)))))

(defun zlc:nintersection (&rest lists)
  "Alter the first argument to be the intersection of all the arguments.
The arguments are lists, regarded as sets.  All elements of the first
argument that do not belong in the intersection are deleted.
Compares elements with EQ."
  (do ((list (car lists) (cdr list))
       (rest (cdr lists))
       (result)
       (old))
      ((null list) result)
    (cond ((do ((x (car list))
		(rest rest (cdr rest)))
	       ((null rest) t)
	     (or (member x (car rest) :test #'eq)
		 (return nil)))
	   (or result (setq result list))
	   (setq old list))
	  (old
	   (rplacd old (cdr list))))))

(defmacro zlc:some (list pred &optional (step ''cdr))
  "Non-NIL if some element of LIST satisfies PRED.
If STEP is specified, it is a function to move down the list
\(default is CDR).  The actual value is the tail of the list
whose CAR is the first element that satisfies PRED."
  (let ((tail (gensym)))
    (once-only (pred step)
      `(do ((,tail ,list (funcall ,step ,tail)))
	   ((null ,tail) nil)
	 (and (funcall ,pred (car ,tail)) (return ,tail))))))

(defmacro zlc:every (list pred &optional (step ''cdr))
  "T if every element of LIST satisfies PRED.
If STEP is specified, it is a function to move down the list
\(default is CDR)."
  (let ((tail (gensym)))
    (once-only (pred step)
      `(do ((,tail ,list (funcall ,step ,tail)))
	   ((null ,tail) t)
	 (or (funcall ,pred (car ,tail)) (return nil))))))

(defun zlc:subst (new old tree)
  "Substitute NEW for every element in TREE that is EQUAL to OLD,
where TREE is a tree of CONSES.  Consing is performed only as needed, 
and TREE is unaltered by the invocation."
  (subst new old tree :test #'equal))

1;;;  Array support*

(defun zlc:array-grow (array &rest dimensions)
  "Alter the dimensions of an array, preserving old contents.
A new array is created and the old one is forwarded; the value is the new one.
Any elements of the old array that are within the bounds of the new one
are copied.  The leader if any is also copied."
  (let ((old-dims (array-dimensions array)))
    ;; Extend or truncate the supplied list of dimensions.
    ;; Omitted dimensions are left unchanged.
    (and (< (length dimensions) (length old-dims))
	 (setq dimensions (append dimensions (nthcdr (length dimensions) old-dims))))
    (and (> (length dimensions) (length old-dims))
	 (setq dimensions (firstn (length old-dims) dimensions))))
  (adjust-array array dimensions))

(compiler:make-obsolete zlc:array-dimension-n
			"use ARRAY-DIMENSION (with a different calling sequence)")

(defun zlc:array-dimension-n (n array)
  "Return the length of dimension N of ARRAY.  The first dimension is N=1.
If N is 0, the leader length is returned, or NIL if ARRAY does not have a
leader (ARRAY-LEADER-LENGTH should be used instead of ARRAY-DIMENSION-N to
find the leader length)."
  (check-arg array arrayp "an array")
  (cond ((> n (array-rank array)))
	((not (plusp n))
	 (array-leader-length array))
	(t
	 (array-dimension array (1- n)))))

(compiler:make-obsolete zlc:array-#-dims array-rank)

(deff zlc:array-#-dims 'array-rank)

(defmacro zlc:arraycall (ignore array &rest dims)
  `(funcall ,array . ,dims))

1;;;  Miscellaneous functions*


(proclaim '(inline zlc:dbg))			;jlm 5/8/89
(defun zlc:dbg ()
  (cerror "Proceed from breakpoint" "Debugger breakpoint"))		;jlm 5/10/89
 
(deff zlc:add1 #'1+)

(defun zlc:mem (pred item list)
  "Return non-NIL if LIST has an element which matches ITEM using PRED.
The value is actually the link of LIST whose CAR is that element.
The args passed to PRED are the ITEM followed by the element of the list."
    (do ((l list (cdr l))) ((null l))
      (and (funcall pred item (car l))
           (return l))))

(defun zlc:ass (pred item a-list)
  "Return the first element of A-LIST whose CAR matches ITEM using PRED.
The args passed to PRED are ITEM followed by the CAR of the A-LIST element."
  (assoc item a-list :test pred))


(deff zlc:greaterp #'>)

(deff zlc:lessp #'<)

(defun zlc:memass (pred item a-list)
  "Return non-NIL if A-LIST has an element whose CAR matches ITEM using PRED.
The value returned is actually the link of A-LIST whose CAR is that element.
The args passed to PRED are the ITEM followed by the CAR of the A-LIST element."
    (do ((l a-list (cdr l)))
	((null l))
      (and (funcall pred item (caar l))
           (return l))))

(deff zlc:plus #'+)

(proclaim '(inline zlc:rass))

(defun zlc:rass (pred item a-list)
  "Return the first element of A-LIST whose CDR matches ITEM using PRED.
The args passed to PRED are the ITEM followed by the CDR of the A-LIST element."
  (rassoc item a-list :test pred))

(proclaim '(inline zlc:subset-not))

(defun zlc:subset-not (pred list)
  "Return a list of all elements of LIST for which PRED is false."
  (remove-if pred list))

(deff zlc:rem-if #'zlc:subset-not)

(proclaim '(inline zlc:subset))

(defun zlc:subset (pred list)
  "Return a list of all elements of LIST for which PRED is true."
  (remove-if-not pred list))

(deff zlc:rem-if-not #'zlc:subset)

(deff zlc:sub1 #'1-)

(deff zlc:times #'*)

(proclaim '(inline zlc:xcons))

(defun zlc:xcons (x y)
  "Returns (CONS Y X)."
  (cons y x))

(proclaim '(inline zlc:xcons-in-area))

(defun zlc:xcons-in-area (x y area)
  "Returns (CONS-IN-AREA Y X AREA)."
  (cons-in-area y x area))

(proclaim '(inline zlc:fixr))

(defun zlc:fixr (flonum)
  "Convert FLONUM to the nearest fixnum."
  (values (round flonum)))

(defun zlc:character (x)
  "Convert X to a character (represented as a fixnum) if possible"
  (char-int (character x)))

(defun zlc:float (number &optional other)
  "Convert NUMBER to a floating point number of same precision as OTHER.
If OTHER is omitted, a single-float is returned."
;;  (declare (optimize (speed 0)(safety 3)))
  (typecase other
    (short-float (small-float number))
    (double-float (double-float number))
    (t (internal-float number))))

(proclaim '(inline zlc:fset-carefully))

(defun zlc:fset-carefully (function-spec definition &optional no-query-flag)
  (fdefine function-spec definition t no-query-flag))

(defun zlc:trunc (dividend &optional (divisor 1))
  "Return DIVIDEND divided by DIVISOR, rounded toward zero, and the remainder."
  (declare (values quotient remainder)
	   (inline truncate))
  (truncate dividend divisor))

(compiler:make-obsolete zlc:trunc truncate)

(defun zlc:ceil (dividend &optional (divisor 1))
  "Return DIVIDEND divided by DIVISOR, rounded up, and the remainder."
  (declare (values quotient remainder)
	   (inline ceiling))
  (ceiling dividend divisor))

(compiler:make-obsolete zlc:ceil ceiling)

(proclaim '(inline zlc:get-from-alternating-list))

(defun zlc:get-from-alternating-list (l key)
  "Retreive associated item from an alternating list.
Like GET, but no initial CAR"
  (get (locf l) key))

(compiler:make-obsolete zlc:get-from-alternating-list getf)

(defun zlc:put-on-alternating-list (item l key)
  "Put an item on an alternating association list.
Modifies the current association, if any.
Otherwise adds one to the head of the list.  
Returns the augmented list as value.
You should alway use this value unless you are
certain there is a current association."
  (prog (pntr)
	(setq pntr l)
     l  (cond ((null l) (return (cons key (cons item l))))
	      ((eq key (car l))
	       (rplaca (cdr l) item)
	       (return l)))
	(setq l (cddr l))
	(go l)))

(defvar status-status-list '(:feature :features :nofeature :status :sstatus :tabsize
			     :userid :site :opsys))

(defvar status-sstatus-list '(:feature :nofeature))

(defun return-status (status-list item item-p)
       (cond ((not item-p) status-list)
	     ((numberp item) (member item status-list :test #'eq))
	     (t (not (null (zlc:mem #'string-equal item status-list))))))

(defun zlc:status (&quote status-function &optional (item nil item-p))
  (selector status-function string-equal
    (('feature 'features) (return-status *features* item item-p))
    (('nofeature) (cond ((not item-p)
			 (ferror nil "too few args to status nofeature."))
			(t (not (return-status *features* item item-p)))))
    (('status) (return-status status-status-list item item-p))
    (('sstatus) (return-status status-sstatus-list item item-p))
    (('tabsize) 8)
    (('userid) user-id)
    (('site) local-host-name)
    (('opsys) :lispm)
    (:otherwise (ferror nil "~S is not a legal STATUS request." status-function))))

(defun zlc:sstatus (&quote status-function item
		    &aux (default-cons-area working-storage-area))
  (if (symbolp item)
      (setq item (intern (string item) *keyword-package*)))
  (selector status-function string-equal
    (('feature) (cond ((not (member item *features* :test #'eq))
		       (setq *features*
			     (cons item *features*))))
		item)
    (('nofeature) (cond ((member item *features* :test #'eq)
			 (setq *features*
			       (delete item (the list *features*) :test #'eq))))
		  item)
    (:otherwise (ferror nil "~S is not a legal SSTATUS request." status-function))))

(defun zlc:get-alternate (x)
  (prog (y)
     l	(cond ((null x) (return (reverse y))))
	(setq y (cons (car x) y))
	(setq x (cddr x))
	(go l)))

;;clm 6/16/88.  Removed; no longer supported.
;;(defprop :cadr #.'cadr-type-code processor-type-code)
;;(defprop :lambda #.lambda-type-code processor-type-code)
;;(defprop :explorer #.chaparral-type-code processor-type-code)
;;(defprop :chaparral #.chaparral-type-code processor-type-code)

;;AB 7-16-87.  Change this just to return clause beginning with :EXPLORER.  
;;             Cross-compilation for LAMBDA, CADR no longer supported.
(defmacro zlc:select-processor (&rest clauses)
  "Selects clause beginning with :EXPLORER"
  (DOLIST (cl clauses)
    (WHEN (EQ (FIRST cl) :explorer)
      (RETURN (SECOND cl)))))

;;;(defmacro zlc:select-processor (&rest clauses)
;;;  "CLAUSES begin with :EXPLORER, :CADR or :LAMBDA."
;;;  `(case processor-type-code
;;;     ,@(mapcar #'(lambda (clause)
;;;		   (cons (get (first clause) 'processor-type-code) (cdr clause)))
;;;	       clauses)))

(defmacro zlc:defunp (function-spec lambda-list &rest body)
  "Like DEFUN, but provides an implicit PROG of no variables around the BODY.
So you can use RETURN to return from the function, and use GO.
There is one difference from an ordinary PROG:
the value of the last element of the BODY is returned.
This is so even if it is an atom.  This is like ordinary DEFUNs."
  (let ((default-cons-area working-storage-area)
	(last nil)
	declares
	doc)
    (setq body (copy-list body))
    (setq last (last body))
    (setf (values body declares doc)
	  (parse-body body nil))
    (cond ((or (atom (car last)) (not (eq 'return (caar last))))
	   (rplaca last (list 'return (car last)))))
    `(defun ,function-spec ,lambda-list
       ,@(if doc (list doc))
       ,(car declares)
       (prog nil . ,body))))


1;;;  ARGS-INFO - 9/20/86 DNG - Original version for Explorer release 3.*

(defconstant %arg-desc-quoted-rest #o20000000)	;Has quoted REST argument
(defconstant %%arg-desc-quoted-rest #o2601)
(defconstant %arg-desc-evaled-rest #o10000000)	;Has evaluated REST argument
(defconstant %%arg-desc-evaled-rest #o2501)
(defconstant %%arg-desc-any-rest #o2502)	;Non-zero if has either kind of REST argument
(defconstant %arg-desc-fef-quote-hair #o4000000)	;Macro-compiled function with hairy quoting,
(defconstant %%arg-desc-fef-quote-hair #o2401)	;caller must check A-D-L for full info
(defconstant %arg-desc-interpreted #o2000000)	;This is an interpreted function, 
(defconstant %%arg-desc-interpreted #o2301)	; no information available (VAL=1000077)
(defconstant %arg-desc-fef-bind-hair #o1000000)	;macro-compiled function with hairy binding,
(defconstant %%arg-desc-fef-bind-hair #o2201)	; linear enter must check A-D-L
(defconstant %%arg-desc-min-args #o0606)	;Minimum number of required args
(defconstant %%arg-desc-max-args #o0006)	;Maximum number of required+optional

;; Note: the undocumented field %%ARG-DESC-FEF-LOCAL-BLOCK-LENGTH is not supported now.
;;   Fields %%ARG-DESC-FEF-BIND-HAIR and %%ARG-DESC-INTERPRETED will always be 0.

(defun zlc:args-info (function)
  (loop while (or (symbolp function)
		  (and (consp function)
		       (not (member (car function) function-start-symbols))))
	do (setq function (fdefinition function)))
  (if (consp function)
      (args-info-from-lambda-list (arglist function t))
    (multiple-value-bind (min max rest quote)
	  (args-desc function)
	(if (and rest quote)
	    (args-info-from-lambda-list (arglist function t))
	  (let ((args-info 0))
	    (setf (ldb %%arg-desc-min-args args-info) min)
	    (setf (ldb %%arg-desc-max-args args-info) max)
	    (when rest
	      (setf (ldb %%arg-desc-evaled-rest args-info) 1))
	    (when quote
	      (setf (ldb %%arg-desc-fef-quote-hair args-info) 1))
	    args-info)))))

(deff zlc:%args-info 'zlc:args-info)

(defun args-info-from-lambda-list (ll &aux (flags 0) quote min (n 0))
  (dolist (arg ll)
    (case arg
      (&quote (setq quote t))
      ((&eval &quote-dontcare) (setq quote nil))
      (&optional (setq min n))
      (&aux (return nil))
      ((&key &rest) (return (setq flags (logior flags
						(cond (quote %arg-desc-quoted-rest)
						      (t %arg-desc-evaled-rest))))))
      (otherwise				;a variable
       (cond ((not (member arg lambda-list-keywords :test #'eq))
	      (if quote				;quoted regular args present
		  (setq flags (logior flags (logior %arg-desc-interpreted
						    %arg-desc-fef-quote-hair))))
	      (setq n (1+ n)))))))
  (or min (setq min n))				;no optionals
  (dpb n %%arg-desc-max-args
       (dpb min %%arg-desc-min-args
	    flags)))

(defun zlc:debugging-info (function &optional unencapsulate-p)
  "Return the debugging info a-list of a function or function spec.
This function is obsolete and inefficient -- it has to build the list each time
it is called.  You should use instead:
  ARGLIST to get the ARGLIST and VALUES
  DOCUMENTATION to get the doc string
  COMPILEDP to get the interpreted definition of a compiled function
  SYS:FUNCTION-PARENT for the parent
  COMPILER:DISASSEMBLE-ARG-NAME for the name of a FEF argument
  COMPILER:DISASSEMBLE-LOCAL-NAME for the name of a FEF local variable
or SI:GET-DEBUG-INFO-STRUCT and SI:GET-DEBUG-INFO-FIELD for any other
system-dependent information."

  ;;  Note: COMPILER:LOCAL-MAP and COMPILER:ARG-MAP are not supported because a
  ;;    different representation is used now and the likelihood of user programs
  ;;    referencing them is too low to be worth the cost of building the old-style
  ;;    lists.

  (let ((dbi (get-debug-info-struct function unencapsulate-p))
	plist (alist nil))
    (if (listp dbi)
	(setq plist dbi)
      (let ((id (dbis-interpreted-definition dbi))
	    (arglist (dbis-arglist dbi)))
	(setq plist (dbis-plist dbi))
	(unless (equal arglist (getf plist ':descriptive-arglist))
	  (push (cons 'compiler:compiler-arglist arglist) alist))
	(when id
	  (push (list 'interpreted-definition id) alist))))
    (do ((pairs plist (cddr pairs)))
	((null pairs))
      (let ((key (first pairs))
	    (value (second pairs)))
	(block add-item
	  (push (case key
		  (:descriptive-arglist (cons 'arglist value))
		  (:values (cons 'values value))
		  ((:internal-fef-offsets :internal-fef-names
		    si:encapsulated-definition si:renamings)
		   (cons key value))
		  (:function-parent (cons 'function-parent value))
		  ((:macros-expanded :documentation :no-simple-substitution
		    :self-flavor :expr-sxhash)
		   (list key value))
		  ((:lexical-parent-debug-info :variables-used-in-lexical-closures
		    compiler:uses-calldest-tail-rec)
		   ;; new items that would not be referenced in old programs.
		   (return-from add-item))
		  (otherwise (list key value)) )
		alist))))
    alist))

1;;;  File-system operations*

(defun zlc:deletef (string-or-stream &optional (error-p t) query?)
  "Delete a file, specified as a pathname, string or I/O stream.
Wildcards are allowed.
QUERY?, if true, means to ask the user before deleting each file.
The value is a list containing one element for each file we considered;
 the element looks like (TRUENAME OUTCOME), where OUTCOME
 is either an error object, NIL if the user said don't delete this one,
 or another non-NIL object if the file was deleted.
 OUTCOME can be an error object only if ERROR-P is NIL.
ERROR-P does not affect errors that happen in determining
 what files match a wildcarded pathname."
  (delete-file string-or-stream :error error-p :query query?))

(defun zlc:renamef (string-or-stream new-name &optional (error-p t) query?)
  "Rename a file, specified as a pathname, string or I/O stream.
Wildcards are allowed.
QUERY?, if true, means ask about each file before renaming it.
Values returned:
1) the first value is normally the defaulted pathname to rename to,
 or a list of such if multiple files were considered.
2) the second value is the old truename of the file considered,
 or a list of old truenames of the files considered.
3) the third value is the outcome, or a list of outcomes.
 An outcome is either a truename if the file was renamed,
 an error object if it failed to be renamed,
 or NIL if the user was asked and said no.
Error objects can appear in the values only if ERROR-P is NIL."
  (declare (values old-name old-truename new-truename))
  (rename-file string-or-stream new-name :error error-p :query query?))

(deff zlc:probef 'probe-file)

(defun zlc:undeletef (string-or-stream &optional (error-p t) query?)
  "Undelete a file, specified as a pathname, string or I/O stream.
Wildcards are allowed.  Not all file servers support undeletion.
QUERY?, if true, means to ask the user before undeleting each file.
The value is a list containing one element for each file we considered;
 the element looks like (TRUENAME OUTCOME), where OUTCOME
 is either an error object, NIL if the user said don't undelete this one,
 or another non-NIL object if the file was undeleted.
 OUTCOME can be an error object only if ERROR-P is NIL.
ERROR-P does not affect errors that happen in determining
 what files match a wildcarded pathname."
  (undelete-file string-or-stream :error error-p :query query?))

(deff zlc:viewf 'view-file)

1;;;  Maclisp support*

;;; Functions for compatibility with MACLISP LEXPRs.  DEFUN-COMPATIBILITY
;;; (in "sys:compiler;zetalisp") is used to convert MACLISP LEXPR and FEXPR 
;;; DEFUNs to Lisp machine form.

(defvar zlc:*lexpr-arglist* :unbound
  "This variable holds the &REST-argument to a converted Maclisp LEXPR.
The Maclisp functions ARG, SETARG and LISTIFY find the arguments here.")

(defun zlc:arg (n)
  "In a Maclisp LEXPR, refer to an argument by its number (origin-1)."
  (cond ((null n) (length zlc:*lexpr-arglist*))
	(t (let ((argptr (nthcdr (1- n) zlc:*lexpr-arglist*)))
	     (cond ((or (<= n 0) (null argptr))
		    (ferror nil "~D is not between 1 and the number of args" n)))
	     (car argptr)))))

(defun zlc:setarg (n x)
  "In a Maclisp LEXPR, refer to an argument by its number (origin-1) and set it to X."
  (let ((argptr (nthcdr (1- n) zlc:*lexpr-arglist*)))
    (cond ((or (<= n 0) (null argptr))
	   (ferror nil "~D is not between 1 and the number of args" n)))
    (rplaca argptr x)
    x))

(defun zlc:listify (n)
  "In a Maclisp LEXPR, return a list of some or all the arguments.
If N is positive, the first N; otherwise, the last -N."
  (cond ((minusp n) (copy-list (nleft (- n) zlc:*lexpr-arglist*)))
	((zerop n) nil)
	(t (firstn n zlc:*lexpr-arglist*))))

;;; Other obsolete MACLISP functions.

(defun zlc:arraydims (array &aux type)
  "Return a list of the array-type and dimensions of ARRAY.
This is an obsolete Maclisp function."
  (and (symbolp array) (setq array (symbol-function array)))
  (check-arg array arrayp "an array")
  (setq type (nth (%p-ldb-offset %%array-type-field array 0) array-types))
  (cons type (array-dimensions array)))

(defun array (&quote x type &eval &rest dimlist)
  "Obsolete Maclisp function for creating an array.  Don't use it."
  (apply (function zlc:*array) (cons x (cons type dimlist))))

(defun zlc:*array (x type &rest dimlist &aux array)
  "Obsolete Maclisp function for growing an array.  Don't use it."
  (and (member type '(readtable obarray) :test #'eq)
       (ferror nil "The array type ~S is not defined in Zetalisp" type))
  (setq array
	(make-array dimlist :type (if (eq type 'flonum) 'art-float 'art-q)))
  (if (eq type 'fixnum)
      (fill-array array nil 0))
  (cond ((null x)
	 array)
	((symbolp x)
	 (rplaca (function-cell-location x) array)
	 x)
	(t (ferror nil "~S is not a legal first arg for *ARRAY" x))))

(defun zlc:maknam (charl)
  (make-symbol (maclisp-make-string charl)))

(defun zlc:implode (x)
  "Obsolete Maclisp function to make a new interned symbol.
X is a list of symbols or numbers, each of which specifies one character
of the pname of the new symbol."
  (let* ((tok (maclisp-make-string x p-n-string))
	 (val (intern tok)))
    (unless (eq (symbol-name val) tok)
      (return-storage (prog1 tok (setq tok nil))))
    val))

(defun maclisp-make-string (charl &optional area &aux pname)
  (let ((%inhibit-read-only t))
    (setq pname (make-array (length charl) :area area :type 'art-string))
    (do ((i 0 (1+ i))
	 (l charl ( cdr l)))
	((null l))
      (setf (aref pname i) (zlc:character (car l))))
    pname))

(defun zlc:explode (x &aux (*iolst nil) (*ioch t))
  "Obsolete Maclisp function to examine printed representation of object X.
It returns a list of symbols, one for each character that would have been printed.
The printing is done with quoting characters."
  (prin1 x (function explode-stream))
  (nreverse *iolst))

(defun zlc:explodec (x &aux (*iolst nil) (*ioch t))
  "Obsolete Maclisp function to examine printed representation of object X.
It returns a list of symbols, one for each character that would have been printed.
The printing is done without quoting characters, like PRINC."
  (princ x (function explode-stream))
  (nreverse *iolst))

(defun zlc:exploden (x &aux (*iolst nil) (*ioch nil))
  "Obsolete Maclisp function to examine printed representation of object X.
It returns a list of numbers (character codes), 
one for each character that would have been printed.
The printing is done without quoting characters, like PRINC."
  (princ x (function explode-stream))
  (mapcar #'char-int (nreverse *iolst)))

(defprop explode-stream t io-stream-p)

(defun explode-stream (operation &optional arg1 &rest rest &aux str oldp)
  (cond ((eq operation :tyo)
	 (cond (*ioch
		(multiple-value-setq (arg1 oldp) (intern (setq str (string arg1))))
		(and oldp (return-array (prog1 str (setq str nil))))))
	 (setq *iolst (cons arg1 *iolst)))
	((eq operation :which-operations)
	 '(:tyo))
	(t (stream-default-handler 'explode-stream operation arg1 rest))))

(defun zlc:getcharn (s n)
  "Obsolete Maclisp function to get Nth char of pname of symbol S, as a number.
N = 1 gets the first character."
  (setq s (string s))
  (cond ((and (> n 0) (<= n (array-active-length s)))
	 (zlc:aref s (1- n)))
	(t 0)))

(defun zlc:getchar (s n)
  "Obsolete Maclisp function to get Nth char of pname of symbol S, as a symbol.
N = 1 gets the first character."
  (setq s (string s))
  (cond ((and (> n 0) (<= n (array-active-length s)))
	 (values (read-from-string (zlc:string (zlc:aref s (1- n))))))
	(t nil)))

(defun zlc:ascii (n)
  "Obsolete Maclisp function to turn character code number N into a symbol.
The symbol's pname has one character, the one with code N."
  (let* ((%inhibit-read-only t)
	 (default-cons-area p-n-string)
	 (str (zlc:string n))
	 (sym (intern str)))
    (unless (eq str (symbol-name sym))
      (return-array (prog1 str (setq str nil))))
    sym))

(defun zlc:readch (&rest read-args &aux ch)
  "Read one character from a stream, and return a symbol with that pname.
Otherwise the same as TYI.  This is an obsolete Maclisp function."
  (declare (arglist stream eof-option))
  (multiple-value-bind (stream eof-option)
      (decode-read-args read-args)
    (if (eq 'readch-eof-option (setq ch (tyi stream 'readch-eof-option)))
	(if (eq eof-option 'no-eof-option)
	    (ferror 'sys:end-of-file-1 "End of file encountered on stream ~s." stream)
	    eof-option)
	(intern (string (int-char ch))))))			;Maclisp "character objects" are in current package.

(proclaim '(inline zlc:samepnamep))

(defun zlc:samepnamep (symbol1 symbol2)
  "Returns T is SYMBOL1 and SYMBOL2 have EQUAL print-names."
  (string= symbol1 symbol2))

(defun zlc:signp (&quote test &eval num)
  "Test the sign of NUM, returning T or NIL.
TEST is a symbol, one of L, LE, G, GE, N or E.
If NUM is not a number, the value is NIL."
  (cond ((not (numberp num)) nil)
	((string-equal test "l") (< num 0))
	((string-equal test "le") (<= num 0))
	((string-equal test "e") (= num 0))
	((string-equal test "n") (neq num 0))
	((string-equal test "ge") (>= num 0))
	((string-equal test "g") (> num 0))
	((ferror nil "~S is not a test name for SIGNP" test))))

(defun zlc:sassoc (item in-list else)
	(or (assoc item in-list :test #'equal)
	    (apply else nil)))

(defun zlc:sassq (item in-list else)
	(or (assoc item in-list :test #'eq)
	    (apply else nil)))

(deff zlc:1+$ #'1+)

(deff zlc:1-$ #'1-)

(deff zlc:+$ #'+)

(deff zlc:-$ #'-)

(deff zlc:*$ #'*)

(deff zlc:/$ #'zlc:/)

(deff zlc:^$ #'zlc:^)