;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Cold-load:T; Base:8 -*- ;;; 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) 1985-1989 Texas Instruments Incorporated. All rights reserved. ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;; Stack Group Functions. Recoded 1/5/78 by DLW. (DEFMACRO COERCE-BOOLEAN-TO-BIT (VARIABLE) `(OR (NUMBERP ,VARIABLE) (SETQ ,VARIABLE (IF ,VARIABLE 1 0)))) (DEFUN MAKE-STACK-GROUP (NAME &REST OPTIONS &KEY (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) &ALLOW-OTHER-KEYS &AUX SG REGULAR-PDL SPECIAL-PDL (sg-area SG-AND-BIND-PDL-AREA) ; these two forced for TGC (special-pdl-area SG-AND-BIND-PDL-AREA) (regular-pdl-area PDL-AREA)) "Create a stack group. NAME, a string, is the name. There are also keyword args. Keywords allowed are: :REGULAR-PDL-SIZE - size of regular pdl in Qs; default is 3000 (octal). :SPECIAL-PDL-SIZE - size of special pdl in Qs; default is 2000 (octal). :TRAP-ENABLE - NIL or 0 means halt on error in this stack group. Default is T! :SAFE - NIL or 0 means allow stack group switching in any order. The last two keywords can be either 1 vs 0 or T vs NIL. Other keywords are obscure and not needed." (COERCE-BOOLEAN-TO-BIT CAR-SYM-MODE) (COERCE-BOOLEAN-TO-BIT CAR-NUM-MODE) (COERCE-BOOLEAN-TO-BIT CDR-SYM-MODE) (COERCE-BOOLEAN-TO-BIT CDR-NUM-MODE) (COERCE-BOOLEAN-TO-BIT SWAP-SV-ON-CALL-OUT) (COERCE-BOOLEAN-TO-BIT SWAP-SV-OF-SG-THAT-CALLS-ME) (COERCE-BOOLEAN-TO-BIT TRAP-ENABLE) (COERCE-BOOLEAN-TO-BIT SAFE) (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 num-args ) "Make stack group SG apply FUNCTION to ARGUMENTS when next resumed." ( declare (special %call-state-length)) ( check-arg sg ( = ( %data-type sg ) dtp-stack-group ) "a stack group" ) ( setq regular-pdl ( sg-regular-pdl sg )) ( setq idx ( do (( argl arguments ( cdr argl )) ( i 0 ( 1+ i ))) (( null argl ) i ) ( setf ( aref regular-pdl i ) ( car argl )) ( %p-store-cdr-code ( aloc regular-pdl i ) ( cond (( null ( cdr argl )) cdr-nil ) ( t cdr-next ))))) ( setq num-args idx ) ( setq idx ( + idx %call-state-length )) ( setf ( sg-initial-function-index sg ) idx ) ;; local pointer of first frame ;; set up quasi function state identifying function and number of parms: ;; Fix to put initial PC in location counter so that when we enter this ;; SG and try to restore previous PC it won't ILLOP. 3-25-87 -ab ( setf ( aref regular-pdl ( + idx %call-state-location-counter-offset )) (if (typep function 'compiled-function) (fef-initial-pc function) 0)) ( setf ( aref regular-pdl ( + idx %call-state-fef )) function ) ( setf ( aref regular-pdl ( + idx %call-state-local-pointer )) 0 ) ( setf ( aref regular-pdl ( + idx %call-state-argument-pointer )) 0 ) ( setf ( aref regular-pdl ( + idx %call-state-call-info )) num-args ) ( setf ( sg-regular-pdl-pointer sg ) ( 1- idx )) ( setf ( sg-pdl-phase sg ) ( 1- 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 ) ;( 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 ) ( setf ( sg-restore-microstack sg ) 0 ) ( setf ( sg-catch-pointer sg ) nil ) sg ) (DEFUN SG-NEVER-RUN-P (STACK-GROUP) "T if stack group has not been run since it was last reset or preset." (LET ((ST (SG-CURRENT-STATE STACK-GROUP))) (OR (= ST SG-STATE-AWAITING-INITIAL-CALL) (= ST 0)))) (DEFUN SG-RESUMABLE-P (STACK-GROUP) "T if it makes sense to resume this stack group." (NOT (LET ((STATE (SG-CURRENT-STATE STACK-GROUP))) (OR (= STATE SG-STATE-ERROR) (= STATE SG-STATE-ACTIVE) (= STATE SG-STATE-EXHAUSTED))))) (defun call-stack-group (sg &rest parms) "The microcode calls this function when it determines that a call is being made to a stack-group." (declare (special current-stack-group)) (without-interrupts (setf (sg-previous-stack-group sg) current-stack-group) (stack-group-resume sg (car parms))))