;; -*- Package:SYSTEM-INTERNALS; Mode:LISP; Base:8 -*-
;; Stack Group Functions.				Recoded 1/5/78 by DLW.
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

(DEFUN MAKE-STACK-GROUP (NAME &REST OPTIONS
			      &AUX
			      ALLOW-UNKNOWN-KEYWORDS
                              (SG-AREA DEFAULT-CONS-AREA)
			      (REGULAR-PDL-AREA PDL-AREA)
			      (SPECIAL-PDL-AREA DEFAULT-CONS-AREA)
			      (REGULAR-PDL-SIZE 3000)
			      (SPECIAL-PDL-SIZE 2000)  ;big for flavors
			      (CAR-SYM-MODE 1)
			      (CAR-NUM-MODE 0)
			      (CDR-SYM-MODE 1)
			      (CDR-NUM-MODE 0)
			      (SWAP-SV-ON-CALL-OUT 1)
			      (SWAP-SV-OF-SG-THAT-CALLS-ME 1)
			      (TRAP-ENABLE 1)
			      (SAFE 1)
			      SG REGULAR-PDL SPECIAL-PDL)
    (DO OP OPTIONS (CDDR OP) (NULL OP)
      (SELECTQ (CAR OP)
	       (:SG-AREA (SETQ SG-AREA (CADR OP)))
	       (:REGULAR-PDL-AREA (SETQ REGULAR-PDL-AREA (CADR OP)))
	       (:SPECIAL-PDL-AREA (SETQ SPECIAL-PDL-AREA (CADR OP)))
	       (:REGULAR-PDL-SIZE (SETQ REGULAR-PDL-SIZE (CADR OP)))
	       (:SPECIAL-PDL-SIZE (SETQ SPECIAL-PDL-SIZE (CADR OP)))
	       (:CAR-SYM-MODE (SETQ CAR-SYM-MODE (CADR OP)))
	       (:CAR-NUM-MODE (SETQ CAR-NUM-MODE (CADR OP)))
	       (:CDR-SYM-MODE (SETQ CDR-SYM-MODE (CADR OP)))
	       (:CDR-NUM-MODE (SETQ CDR-NUM-MODE (CADR OP)))
	       (:SWAP-SV-ON-CALL-OUT (SETQ SWAP-SV-ON-CALL-OUT (CADR OP)))
	       (:SWAP-SV-OF-SG-THAT-CALLS-ME (SETQ SWAP-SV-OF-SG-THAT-CALLS-ME (CADR OP)))
	       (:TRAP-ENABLE (SETQ TRAP-ENABLE (CADR OP)))
	       (:SAFE (SETQ SAFE (CADR OP)))
	       (:ALLOW-UNKNOWN-KEYWORDS (SETQ ALLOW-UNKNOWN-KEYWORDS (CADR OP)))
	       (OTHERWISE (OR ALLOW-UNKNOWN-KEYWORDS
			      (FERROR NIL "~S is not a valid option" (CAR OP))))))


    (AND (< REGULAR-PDL-SIZE 400)
	(FERROR NIL "Regular PDL size ~O not at least 400" REGULAR-PDL-SIZE))
    (SETQ SG (MAKE-ARRAY 0 ':AREA SG-AREA ':TYPE 'ART-STACK-GROUP-HEAD
			   ':LEADER-LENGTH (LENGTH STACK-GROUP-HEAD-LEADER-QS)))
    (SETQ SPECIAL-PDL (MAKE-ARRAY SPECIAL-PDL-SIZE
				  ':AREA SPECIAL-PDL-AREA
				  ':TYPE 'ART-SPECIAL-PDL 
				  ':LEADER-LENGTH (LENGTH SPECIAL-PDL-LEADER-QS)))
    (SETQ REGULAR-PDL (MAKE-ARRAY REGULAR-PDL-SIZE
				  ':AREA REGULAR-PDL-AREA
				  ':TYPE 'ART-REG-PDL
				  ':LEADER-LENGTH (LENGTH REG-PDL-LEADER-QS)))
    (SETF (REGULAR-PDL-SG REGULAR-PDL) (%MAKE-POINTER DTP-STACK-GROUP SG))
    (SETF (SPECIAL-PDL-SG SPECIAL-PDL) (%MAKE-POINTER DTP-STACK-GROUP SG))
    (SETF (SG-NAME SG) NAME)
    (SETF (SG-REGULAR-PDL SG) REGULAR-PDL)
    (SETF (SG-REGULAR-PDL-LIMIT SG) (- REGULAR-PDL-SIZE 100))
    (SETF (SG-SPECIAL-PDL SG) SPECIAL-PDL)
    (SETF (SG-SPECIAL-PDL-LIMIT SG) (- SPECIAL-PDL-SIZE 40))
    (SETF (SG-SAVED-M-FLAGS SG) 0)
    (SETF (SG-FLAGS-CAR-SYM-MODE SG) CAR-SYM-MODE)
    (SETF (SG-FLAGS-CAR-NUM-MODE SG) CAR-NUM-MODE)
    (SETF (SG-FLAGS-CDR-SYM-MODE SG) CDR-SYM-MODE)
    (SETF (SG-FLAGS-CDR-NUM-MODE SG) CDR-NUM-MODE)
    (SETF (SG-STATE SG) 0)
    (SETF (SG-SWAP-SV-ON-CALL-OUT SG) SWAP-SV-ON-CALL-OUT)
    (SETF (SG-SWAP-SV-OF-SG-THAT-CALLS-ME SG) SWAP-SV-OF-SG-THAT-CALLS-ME)
    (SETF (SG-FLAGS-TRAP-ENABLE SG) TRAP-ENABLE)
    (SETF (SG-SAFE SG) SAFE)
    (%MAKE-POINTER DTP-STACK-GROUP SG))

(DEFUN STACK-GROUP-PRESET (SG FUNCTION &REST ARGUMENTS
			      &AUX REGULAR-PDL IDX)
    (CHECK-ARG SG (= (%DATA-TYPE SG) DTP-STACK-GROUP) "a stack group")
    (SETQ REGULAR-PDL (SG-REGULAR-PDL SG))
    (AS-1 0 REGULAR-PDL 0)
    (AS-1 0 REGULAR-PDL 1)
    (AS-1 0 REGULAR-PDL 2)
    (AS-1 FUNCTION REGULAR-PDL 3)
    (SETF (SG-INITIAL-FUNCTION-INDEX SG) 3)
    (SETF (SG-AP SG) 3)
    (SETF (SG-IPMARK SG) 3)
    (SETQ IDX (DO ((ARGL ARGUMENTS (CDR ARGL))
		   (I 4 (1+ I)))
		  ((NULL ARGL)
		   (1- I))				;Undo the last 1+
		(AS-1 (CAR ARGL) REGULAR-PDL I)
		(%P-STORE-CDR-CODE (AP-1 REGULAR-PDL I)
				   (COND ((NULL (CDR ARGL)) CDR-NIL)
					 (T CDR-NEXT)))))
    (SETF (SG-REGULAR-PDL-POINTER SG) IDX)
    (SETF (SG-PDL-PHASE SG) IDX)
    (SETF (SG-SPECIAL-PDL-POINTER SG) -1)
    (SETF (SG-CURRENT-STATE SG) SG-STATE-AWAITING-INITIAL-CALL)
    (SETF (SG-FOOTHOLD-EXECUTING-FLAG SG) 0)
    (SETF (SG-FOOTHOLD-DATA SG) NIL)			;EH depends on this
    (SETF (SG-FLAGS-QBBFL SG) 0)
    (SETF (SG-PROCESSING-ERROR-FLAG SG) 0)
    (SETF (SG-PROCESSING-INTERRUPT-FLAG SG) 0)
    (SETF (SG-IN-SWAPPED-STATE SG) 0)
    SG)