;-*-LISP-*-   Lisp machine utility functions.
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

(DECLARE (GENPREFIX *UTIL*))

(DEFUN READFILE NARGS
  (PROG (FILE TEM LAST-THING-READ ^Q) 
	(COND ((NOT (= 0 NARGS))
		(SETQ FILE (ARG 1))))
;	(APPLY 'UREAD FILE)
	(INPUSH (OPEN FILE))
	(SETQ ^Q T)
  LP	(COND ((NULL (ERRSET (SETQ TEM (READ 'FOOBAR))))(GO E1))
	      ((EQ TEM 'FOOBAR)
		(RETURN T)))
	(SETQ LAST-THING-READ TEM)
	(COND ((NULL (ERRSET (EVAL TEM))) (GO E1)))
	(GO LP)
  E1    (SETQ ^W NIL)
	(PRINT FILE)
	(PRINT LAST-THING-READ)
	(BREAK 'FOO T)
	(GO LP)))

(DEFUN READ-FUNCTIONS-FROM-FILE NARGS 
  (PROG (FILE TEM LAST-THING-READ FUNCTION-LIST LOADED-LIST ^Q)
	(SETQ FUNCTION-LIST (ARG 1))
	(COND ((NOT (= 1 NARGS))
		(SETQ FILE (ARG 2))))
;	(APPLY 'UREAD FILE)
	(INPUSH (OPEN FILE))
	(SETQ ^Q T)
  LP	(COND ((NULL (ERRSET (SETQ TEM (READ 'FOOBAR)))) (GO E1))
	      ((EQ TEM 'FOOBAR)
		(RETURN LOADED-LIST)))
	(SETQ LAST-THING-READ TEM)
	(COND ((NOT 
	        (AND (EQ (CAR LAST-THING-READ) 'DEFUN)
		     (MEMQ (CADR LAST-THING-READ) FUNCTION-LIST)))
		(GO LP)))
	(SETQ LOADED-LIST (CONS (CADR LAST-THING-READ) LOADED-LIST))
	(COND ((NULL (ERRSET (EVAL TEM))) (GO E1)))
	(GO LP)
  E1    (SETQ ^W NIL)
	(PRINT FILE)
	(PRINT LAST-THING-READ)
	(BREAK 'FOO T)
	(GO LP)))

(DEFUN FIND-ALL-SYMBOLS-WITH-PROPERTY (PROP) 
   (PROG (TEM I LST) 
	(SETQ I 0)
  L1	(SETQ TEM (FUNCALL OBARRAY I))
  L	(COND ((NULL TEM) (GO L2))
	      ((GET (CAR TEM) PROP) 
		(SETQ LST (CONS (CAR TEM) LST))))
	(SETQ TEM (CDR TEM))
	(GO L)
  L2	(COND ((< (SETQ I (1+ I)) 777)
		(GO L1)))
	(RETURN LST)
))
 
(DEFUN LIST-SUM (X)
  (PROG (ANS)
	(SETQ ANS 0)
L	(COND ((NULL X) (RETURN ANS)))
	(SETQ ANS (+ ANS (ATOMEVAL (CAR X))))
	(SETQ X (CDR X))
	(GO L)))

(DEFUN LIST-PRODUCT (X)
  (PROG (ANS)
	(SETQ ANS 1)
L	(COND ((NULL X) (RETURN ANS)))
	(SETQ ANS (* ANS (ATOMEVAL (CAR X))))
	(SETQ X (CDR X))
	(GO L)))

(DEFUN ATOMEVAL (X)
	(COND ((NUMBERP X) X)
	      (T (SYMEVAL X))))

(DEFUN GET-ALTERNATE (X)
   (PROG (Y)
    L	(COND ((NULL X)(RETURN (REVERSE Y))))
	(SETQ Y (CONS (CAR X) Y))
	(SETQ X (CDDR X))
	(GO L)))

(DEFUN ASSIGN-ALTERNATE (X)
   (PROG NIL 
    L	(COND ((NULL X)(RETURN NIL)))
	(SET (CAR X) (CADR X))
	(SETQ X (CDDR X))
	(GO L)))

(DEFUN ASSIGN-VALUES-FROM-LIST (X)
  (PROG NIL 
     A	(COND ((NULL X) (RETURN NIL)))
	(SET (CAAR X) (LIST-SUM (CDAR X)))
	(SETQ X (CDR X))
	(GO A)))

(DEFUN LENGTH-TERM-BY-ATOM (X)
  (PROG (N)
	(SETQ N 0)
   L 	(COND ((ATOM X) (RETURN N)))
	(SETQ X (CDR X))
	(SETQ N (1+ N))
	(GO L)))

(DEFUN LAST-TERM-BY-ATOM (X)
  (PROG NIL 
	(COND ((ATOM X) (RETURN X)))
    L	(COND ((ATOM (CDR X)) (RETURN X)))
	(SETQ X (CDR X))
	(GO L)))

(DEFUN ALLREMPROP (INDICATOR) (MAPATOMS (FUNCTION (LAMBDA (X) (REMPROP X INDICATOR)))))

;(DEFUN ALLREMPROP (INDICATOR)
;     (DO I 0 (1+ I) (NOT (< I 777))
;	(MAPC (FUNCTION 
;		(LAMBDA (X) (REMPROP X INDICATOR)))
;	      (OBARRAY I)))
;)

(DEFUN PUTPROPL (ALT-LIST INDICATOR)
	(PROG NIL
 A	(COND ((NULL ALT-LIST) (RETURN NIL)))
	(PUTPROP (CAR ALT-LIST) (CADR ALT-LIST) INDICATOR)
	(SETQ ALT-LIST (CDDR ALT-LIST))
	(GO A)))

(DEFUN ASSIGN-BIT-POSITIONS (INPUT-LIST LOW-BIT)
   (PROG NIL 
LP	(COND ((NULL INPUT-LIST) (RETURN LOW-BIT)))
	(SET (CAR INPUT-LIST) LOW-BIT)
	(SETQ LOW-BIT (LSH LOW-BIT 1))
	(SETQ INPUT-LIST (CDR INPUT-LIST))
	(GO LP)))

(DEFUN ASSIGN-VALUES (INPUT-LIST SHIFT)
   (PROG (TEM)
	(SETQ TEM 0)
LP	(COND ((NULL INPUT-LIST)(RETURN TEM)))
	(SET (CAR INPUT-LIST) (LSH TEM SHIFT))
	(SETQ INPUT-LIST (CDR INPUT-LIST))
	(SETQ TEM (1+ TEM))
	(GO LP)))

(DEFUN ASSIGN-VALUES-INIT-DELTA (INPUT-LIST SHIFT INIT DELTA)
    (PROG NIL 
LP	(COND ((NULL INPUT-LIST) (RETURN INIT)))
	(SET (CAR INPUT-LIST) (LSH INIT SHIFT))
	(SETQ INPUT-LIST (CDR INPUT-LIST))
	(SETQ INIT (+ INIT DELTA))
	(GO LP)))

(DEFUN FIND-POSITION-IN-LIST (ITEM IN-LIST)
  (PROG (C)
	(SETQ C 0)
L	(COND ((NULL IN-LIST) (RETURN NIL))
	      ((EQ (CAR IN-LIST) ITEM) (RETURN C)))
	(SETQ C (1+ C))
	(SETQ IN-LIST (CDR IN-LIST))
	(GO L)))

	       
(DEFUN FIND-POSITION-IN-LIST-EQUAL (ITEM IN-LIST)
  (PROG (C)
	(SETQ C 0)
  L	(COND ((NULL IN-LIST) (RETURN NIL))
	      ((EQUAL (CAR IN-LIST) ITEM) (RETURN C)))
	(SETQ C (1+ C))
	(SETQ IN-LIST (CDR IN-LIST))
	(GO L)))

(DEFUN LIST-ASSQ (ITEM IN-LIST)
  (PROG NIL 
    L	(COND ((NULL IN-LIST) (RETURN NIL))
	      ((EQ ITEM (CAR IN-LIST))
		(RETURN (CADR IN-LIST))))
	(SETQ IN-LIST (CDDR IN-LIST))
	(GO L)))

(DEFUN ASSQR (ITEM REVERSED-A-LIST)	;LIKE ASSQ, BUT KEY IN CDAR INSTEAD OF CAAR
   (PROG NIL 
   L	(COND ((NULL REVERSED-A-LIST) (RETURN NIL))
	      ((EQ ITEM (CDAR REVERSED-A-LIST))
		(RETURN (CAR REVERSED-A-LIST))))
	(SETQ REVERSED-A-LIST (CDR REVERSED-A-LIST))
	(GO L)))

(DECLARE (FIXNUM N1 N2))
(DECLARE (FIXNUM (LOGAND FIXNUM FIXNUM) (LOGIOR FIXNUM FIXNUM) (LOGXOR FIXNUM FIXNUM)))

(DEFUN LOGAND (N1 N2)
	(BOOLE 1 N1 N2))

(DEFUN LOGIOR (N1 N2)
	(BOOLE 7 N1 N2))

(DEFUN LOGXOR (N1 N2)
	(BOOLE 6 N1 N2))

;TYPE ARRAY ENTRIES
(DEFUN T-A (ARRAY FROM N)
  (PROG (IDX)
	(SETQ IDX FROM)
  L	(COND ((< N 1)
		(RETURN T)))
	(PRINT (LIST ARRAY IDX))
	(PRIN1 (FUNCALL ARRAY IDX))
	(SETQ IDX (1+ IDX))
	(SETQ N (1- N))
	(GO L)))

;FLUSHES ITEM BY SMASHING IT OUT, UNLESS IT IS THE FIRST ELEMENT
; IN WHICH CASE IT JUST RETURNS CDR OF THE ARG.
(DEFUN DELETE-FROM-LIST (ITEM LST)
  (PROG (TEM)
	(SETQ TEM LST)
	(COND ((NULL TEM) (GO X))
	      ((EQ ITEM (CAR TEM)) (RETURN (CDR TEM))))
   L	(COND ((NULL (CDR TEM)) (GO X))
	      ((EQ ITEM (CADR TEM))
		(RPLACD TEM (CDDR TEM))
		(GO X)))
	(SETQ TEM (CDR TEM))
	(GO L)
   X	(RETURN LST)))

;Maclisp version of DEFMIC.  Used when reading in LISPM;DEFMIC >
;Put on QLVAL and QINTCMP properties
;Creates MISC-FUNCTION-LIST for STORE-MISC-LINK  (CALLED FROM STORE-MISC-U-ENTRY-LINKS)
; and MISC-INSTRUCTION-LIST for STORE-MICRO-CODE-SYMBOL-NAMES

(DECLARE (SPECIAL MISC-FUNCTION-LIST MISC-INSTRUCTION-LIST))

(DEFUN DEFMIC FEXPR (X)
  (PROG (NAME OPCODE ARGLIST LISP-FUNCTION-P NO-QINTCMP
	 FUNCTION-NAME INSTRUCTION-NAME)
    (SETQ NAME (CAR X)
	  OPCODE (CADR X)
	  ARGLIST (CADDR X)
	  LISP-FUNCTION-P (CADDDR X))
    (AND (CDDDDR X) (SETQ NO-QINTCMP (CAR (CDDDDR X))))
    (COND ((ATOM NAME)
	   (SETQ FUNCTION-NAME NAME INSTRUCTION-NAME NAME))
	  ((SETQ FUNCTION-NAME (CAR NAME) INSTRUCTION-NAME (CDR NAME))))
    (COND ((NOT NO-QINTCMP)
	   (PUTPROP INSTRUCTION-NAME (LENGTH ARGLIST) 'QINTCMP)
	   (OR (EQ FUNCTION-NAME INSTRUCTION-NAME)
	       (PUTPROP FUNCTION-NAME (LENGTH ARGLIST) 'QINTCMP))))
    (PUTPROP INSTRUCTION-NAME OPCODE 'QLVAL)
    (SETQ MISC-INSTRUCTION-LIST (CONS INSTRUCTION-NAME MISC-INSTRUCTION-LIST))
    (AND LISP-FUNCTION-P
	 (SETQ MISC-FUNCTION-LIST (CONS NAME MISC-FUNCTION-LIST)))))

;; LISTP is used by some macros, including PSETQ.
(DEFUN LISTP (X)
       (NOT (ATOM X)))

(DEFUN NLISTP (X)
       (ATOM X))