;	** (c) Copyright 1980 Massachusetts Institute of Technology **
(DECLARE (GENPREFIX *UTIL2*))

;NUMERIC ARG DESC FIELDS FROM QCOM
(DECLARE (SPECIAL %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST LAMBDA-LIST-KEYWORDS
   %ARG-DESC-FEF-QUOTE-HAIR %ARG-DESC-INTERPRETED 
   %ARG-DESC-FEF-BIND-HAIR %%ARG-DESC-MIN-ARGS %%ARG-DESC-MAX-ARGS))

;PROPERTIES USED IN MACLISP TO FLAG PROPERTIES OF LISP MACHINE FUNCTIONS:
; (IN ORDER OF "PRIORITY". NOTED BELOW IS WHETHER PROPERTY IS STORED ON THE
;   FCTN (IE PRINT) OR THE HEAD (IE Q-PRINT))

;FCTN  ARGDESC  ( (<COUNT> <LIST OF ADL KEYWORD TOKENS>) .. )
;FCTN  QINTCMP  <NUMBER-OF-ARGS>  FLAGS FUNCTIONS THAT ARE TO BE COMPILED INTO 
;	MISC-INSTRUCTION CALLS.   NUMBER OF ARGS MUST THEREFORE BE FIXED.
;FCTN  Q-ARGS-PROP <NUMBER AS RETURNED BY %ARGS-INFO ON REAL MACHINE>
;	HOWEVER, %ARG-DESC-FEF-BIND-HAIR BIT IS ALWAYS 0 (TOO HAIRY TO FIGURE OUT HERE).
;HEAD  EXPR  <LAMBDA EXP OR ATOM>  DETERMINE PROP BY MUNCHING DOWN LAMBDA LIST.
;FCTN  FEXPR,FSUBR  ARGS PROP IS %ARG-DESC-QUOTED-REST.
;FCTN  PDP-10 ARGS FUNCTION. 

;  DEPEND-ON-BEING-MICRO-COMPILED.  T OR LIST TERMINATED BY ATOM!  ENABLES COMPILATION
;	OF MICRO-TO-MICRO CALLS TO THE FUNCTION WITH THIS PROPERTY EXCEPT WHEN
;	MICRO-COMPILING A FUNCTION ON THE LIST (IF ANY).  (THIS FEATURE ENABLES
;	ONE TO "BREAK" RECURSIVE CHAINS AND THUS AVOID EXCEEDING THE HARDWARE LIMITED
;	DEPTH OF THE MICRO-STACK ON THE REAL MACHINE.)

; Q-HEAD-POINTER. POINTS A HEAD IF NOT THE SAME AS FCTN.  THIS ALLOWS COMPILER
;TO FIND IT WHEN A CALL IS BEING COMPILED FOR ERROR CHECKING.

;NOTES:
; ALL Q-ARGS-PROPS ARE REMOVED AT THE START OF A MAJOR OPERATION (IE WHERE NEW
;  DEFINITIONS MAY HAVE BEEN READ IN BY THE USER SINCE THE Q-ARGS-PROP S WERE PUT ON).
; ARGDESC PROPERTIES ARE NOT PUT ON AUTOMATICALLY.  THEY ARE PUT ON BY "HAND" IN
;EXTRA SPECIAL FUNNY CASES WHERE THEY ARE NECESSARY.

(DEFUN GET-Q-ARGS-PROP (FCTN HEAD)  ;FCTN MUST BE "REAL" NAME, IE PRINT NOT Q-PRINT
  (PROG (TEM)
	(COND ((NULL HEAD) (RETURN NIL))	;SPECIAL-PROCESSING (HOPEFULLY)
	      ((NOT (EQ HEAD FCTN)) (PUTPROP FCTN HEAD 'Q-HEAD-POINTER)))
	(COND ((SETQ TEM (GET FCTN 'ARGDESC))
		(RETURN (GET-Q-ARGS-PROP-FROM-ARGDESC-PROP TEM)))
	      ((SETQ TEM (GET FCTN 'QINTCMP))
		 (RETURN (+ (LSH TEM 6) TEM)))
	      ((SETQ TEM (GET FCTN 'Q-ARGS-PROP))
		 (RETURN TEM))
	      ((SETQ TEM (GET HEAD 'EXPR))
		 (COND ((ATOM TEM) (RETURN (GET-Q-ARGS-PROP TEM TEM)))
		       ((EQ (CAR TEM) 'LAMBDA)
			  (RETURN (GET-Q-ARGS-PROP-FROM-LAMBDA-LIST (CADR TEM))))
		       (T (GO E1))))
	      ((GETL TEM '(FEXPR FSUBR))
		 (RETURN %ARG-DESC-QUOTED-REST))
	      ((SETQ TEM (ARGS FCTN))
;		 (RETURN 		;CAUSES CALL-FOR-JONL
;		   (+ (LSH (COND ((CAR TEM)) (T (CDR TEM))) 6)
;		      (CDR TEM)))
		  (RETURN 
		   (COND ((CAR TEM)
			   (+ (LSH (CAR TEM) 6) (CDR TEM)))
			 (T (+ (LSH (CDR TEM) 6) (CDR TEM))))))
	      (T (GO E1)))
   E1	(BARF FCTN 'ASSUMED-INTERPRETED 'WARN)
	(RETURN (+ %ARG-DESC-INTERPRETED 77))
))

(DEFUN GET-Q-ARGS-PROP-FROM-ARGDESC-PROP (ARG-DESC)
  (PROG (PROP MIN-ARGS MAX-ARGS COUNT ITEM)
	(SETQ PROP 0 MIN-ARGS 0 MAX-ARGS 0)
   L	(COND ((NULL ARG-DESC) (RETURN (+ PROP (LSH MIN-ARGS 6) MAX-ARGS))))
	(SETQ COUNT (CAAR ARG-DESC))
	(SETQ ITEM (CADAR ARG-DESC)) ;LIST OF ARG SYNTAX, QUOTE TYPE, OTHER ATTRIBUTES
	(SETQ ARG-DESC (CDR ARG-DESC))
   L1	(COND ((= 0 COUNT) (GO L))
	      ((MEMQ 'FEF-ARG-REST ITEM) (GO R1))
	      ((MEMQ 'FEF-ARG-REQ ITEM)
		(SETQ MIN-ARGS (1+ MIN-ARGS))
		(GO O1))
	      ((MEMQ 'FEF-ARG-OPT ITEM)
		(GO O1)))
    L2	(SETQ COUNT (1- COUNT))
	(GO L1)
    O1	(SETQ MAX-ARGS (1+ MAX-ARGS))
	(COND ((NOT (MEMQL '(FEF-QT-EVAL FEF-QT-DONTCARE) ITEM))
		(SETQ PROP (LOGIOR PROP %ARG-DESC-FEF-QUOTE-HAIR))))
	(GO L2)
    R1	(SETQ PROP (LOGIOR PROP (COND ((MEMQL '(FEF-QT-EVAL FEF-QT-DONTCARE) ITEM)
					%ARG-DESC-EVALED-REST)
				      (T %ARG-DESC-QUOTED-REST))))
	(GO L)
))

		
(DEFUN GET-Q-ARGS-PROP-FROM-LAMBDA-LIST (LL)
  (PROG (QUOTE-STATUS REST-FLAG MIN-ARGS MAX-ARGS OPT-FLAG PROP)
	(SETQ QUOTE-STATUS '&EVAL MIN-ARGS 0 MAX-ARGS 0 PROP 0)
    L	(COND ((OR (ATOM LL) (EQ (CAR LL) '&AUX))
		 (GO X1))
	      ((EQ (CAR LL) '&OPTIONAL) (SETQ OPT-FLAG T) (GO L1))
	      ((MEMQ (CAR LL) '(&EVAL &QUOTE &QUOTE-DONTCARE))
		(SETQ QUOTE-STATUS (CAR LL))
		(GO L1))
	      ((EQ (CAR LL) '&REST) (SETQ REST-FLAG T) (GO L1))
	      ((MEMQ (CAR LL) LAMBDA-LIST-KEYWORDS)
	       (GO L1)))
	(COND (REST-FLAG (GO R1))
	      ((NULL OPT-FLAG) (SETQ MIN-ARGS (1+ MIN-ARGS))))
	(SETQ MAX-ARGS (1+ MAX-ARGS))
	(COND ((NOT (MEMQ QUOTE-STATUS '(&EVAL &QUOTE-DONTCARE)))
		(SETQ PROP (LOGIOR PROP %ARG-DESC-FEF-QUOTE-HAIR))))  ;QUOTED SPREAD ARG
    L1	(SETQ LL (CDR LL))
	(GO L)
    R1	(SETQ PROP (LOGIOR PROP (COND ((MEMQ QUOTE-STATUS '(&EVAL &QUOTE-DONTCARE))
					 %ARG-DESC-EVALED-REST)
				      (T %ARG-DESC-QUOTED-REST))))
    X1	(RETURN (+ PROP (LSH MIN-ARGS 6) MAX-ARGS))
 ))
	      
(DEFUN QC-PUT-Q-ARGS-PROP (ELEMENT F-NAME F-HEAD PROCESSING-MODE OUTPUT-MODE)
  (PROG NIL 
	(COND ((NULL F-HEAD) (RETURN NIL))
	      ((MEMQ PROCESSING-MODE '(MICRO-COMPILE MACRO-COMPILE))
		(PUTPROP F-NAME (GET-Q-ARGS-PROP F-NAME F-HEAD) 'Q-ARGS-PROP)) ) ))

(DEFUN QC-REMOVE-Q-ARGS-PROP (ELEMENT F-NAME F-HEAD PROCESSING-MODE OUTPUT-MODE)
  (PROG NIL 
	(COND ((NULL F-HEAD) (RETURN NIL)))
	(REMPROP F-NAME 'Q-ARGS-PROP)
	(REMPROP F-NAME 'Q-HEAD-POINTER)))

(DEFUN QC-PUT-DEPEND-PROP (ELEMENT F-NAME F-HEAD PROCESSING-MODE OUTPUT-MODE)
  (PROG NIL 
	(COND ((NULL F-HEAD) (RETURN NIL)))
	(COND ((EQ PROCESSING-MODE 'MICRO-COMPILE)
		(PUTPROP F-NAME 
			 T 
;			(COND ((EQ F-NAME F-HEAD) T)
;			      (T F-HEAD)) 
			'DEPEND-ON-BEING-MICRO-COMPILED))) ))

(DECLARE (FIXNUM (Q-CHAR-LENGTH NOTYPE)))

(DEFUN Q-CHAR-LENGTH (CHLIST)
  (PROG (LEN)
	(DECLARE (FIXNUM LEN))
	(SETQ LEN 0)
   L	(COND ((NULL CHLIST) (RETURN LEN))
	      ((= (CAR CHLIST) 26)		; (TOP I)
		(SETQ CHLIST (CDDDR CHLIST))))  ;COUNT GRITCH AND THREE FOLLOWING AS ONE
	(SETQ LEN (1+ LEN))
	(SETQ CHLIST (CDR CHLIST))
	(GO L)))

(DECLARE (FIXNUM (Q-CHAR-CHOMP NOTYPE)))

(DEFUN Q-CHAR-CHOMP (CHLIST)
  (PROG (ANS COUNT)
	(DECLARE (FIXNUM ANS COUNT))
	(COND ((NULL CHLIST) (RETURN 200))
	      ((= (CAR CHLIST) 15) (RETURN 215))	;CONVERT CR.
	      ((NOT (= (CAR CHLIST) 26)) (RETURN (CAR CHLIST))))
	(SETQ ANS 0 COUNT 3 CHLIST (CDR CHLIST))
   L	(COND ((OR (NOT (NUMBERP (CAR CHLIST)))
		   (< (CAR CHLIST) 60)
		   (> (CAR CHLIST) 71))
		(BARF CHLIST 'BAD-CHAR-FOLLOWING-CIRCLE-TIMES 'DATA)))
	(SETQ ANS (+ (* ANS 10) (- (CAR CHLIST) 60)))
	(SETQ CHLIST (CDR CHLIST))
	(COND ((= 0 (SETQ COUNT (1- COUNT)))
		(RETURN ANS)))
	(GO L)))

(DEFUN Q-CHAR-ADVANCE (CHLIST)
	(COND ((NULL CHLIST) NIL)
	      ((NOT (= (CAR CHLIST) 26)) (CDR CHLIST))
	      (T (CDDDDR CHLIST))))

(DEFUN CHOMP FEXPR (X)					;(FILE FN1 FN2 ...)
    (PROG (REAL LIST)
       (SETQ REAL T)
       (SETQ LIST (CONS (COND (REAL '(SET-DEFAULT-MACRO-COMPILE))
			      (T '(SET-DEFAULT-MICRO-COMPILE)))
			(CDR X)))
       (SET (CAR X) LIST)
       (QC (CAR X))))