;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-

;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;       ** Enhancements (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.

(DEFCONST *LAM-UCODE-BASE-FILENAME* "lam2:ubin;ulambda")

(DEFCONST *LAM-UCODE-99-BASE-FILENAME* "LAM3: QL.UBIN;ULAMBDA")
(DEFCONST *LAM-UCODE-104-BASE-FILENAME* "dj: l.UBIN;ULAMBDA")

(DEFCONST *LAM-PROM-DIRECT-FILE* "SYS:UBIN;BOOTSTRAP LAM-ULOAD")

(defun get-ucode-from-sys ()
  (setq *lam-ucode-base-filename*
	(fs:merge-pathname-defaults "sys:" *lam-ucode-base-filename*))
  (setq *lam-prom-direct-file*
	(fs:merge-pathname-defaults "sys:" *lam-prom-direct-file*)))

(defun get-ucode-from-diag-host ()
  (setq *lam-ucode-base-filename*
	(fs:merge-pathname-defaults "diag-host:" *lam-ucode-base-filename*))
  (setq *lam-prom-direct-file*
	(fs:merge-pathname-defaults "diag-host:" *lam-prom-direct-file*)))

;Lambda Machine Console Program

;Documentation:

;It's like DDT
; ie <register>/  "opens" the register and prints it out.
;    <new value><cr>  when a register is open modifies the register and closes it.
;    <lf>  opens the next higher register and prints it.
;    ^     opens the next lower register and prints it.
;    <space> or +  act as arithmetic +.
;    <tab> open quantity addressed by pointer field of last quantity typed.
;    <page>  refreshes display
;    =   types numeric value of last value typed (by you or it)

;Further Documentation:
;
;^R	reset
;^N	step
;n^N	step n times, n < 40000
;adr^N	step until about to execute micro instr at adr
;:AUTO-STEP  step in loop until character typed.
;^P	run until char typed
;^L	clear screen
;^S     stop machine
;^T     start machine and enter remote console mode.
;105 FOOBAR  start machine
; <arg>:G  (arg a control-mem register address).  set PC of machine preparitory to starting.
;
; :MODIFY prints uinsts in OPC buffer which modify arg (an A or M location). if no arg,
;	   print those which modify open location (which should be in A or M memory).
; :AFFECT prints uinsts which "affect" this uinst (modify register addressed by A or M address
;	  of this guy).
; :DESCRIBE-AREAS  give information about areas
; :AREA   prints area that last value typed points to.
; :REGION prints region that last value typed points to.
; :DESCRIBE-REGION give information about region <arg>.
; :system-communication-area  print entire contents of system-communication-area
; :scratch-pad-init-area      similar.
; :MAPS   prints maps (1st and 2nd level) addressed by last value typed.
; :STKP   give backtrace of info on stack. Preceeding numeric arg is number of
;	  frames worth.  All are printed if arg is absent.  If arg negative,
;	  print (abs arg) frames direct from PDL-BUFFER (bypassing memory mapping, etc).
;	  Any character typed during printout will abort rest of printout.
; :TRACE  like :STKP except that if the last value examined is a stack group
;	  that stack group will be traced instead of the current one.
; :TRACEN like TRACE, but doesnt print args.
; :ATOM foo  tell about atomic symbol foo
; :FUNCTION foo  tell about foo's function cell
; :PROPERTY foo  tell about foo's property list.
; :BACTRACE
; :BACKTRACE
; :MEMSTAT tell all about all pages that are swapped in
; :RELPC  types out what M-AP points to, and if thats a FEF, prints out what
;	  LC is relative to that.
; :CODE   disassembles the macrocoded function being executed.
; :DISASSEMBLE-FEF  disassembles last quantity typed.  Asks for center-PC or NIL.
; :CHECK-MAP  checks contents of hardware map against PAGE-HASH-TABLE. 
;	(takes quite a long time)
; :CHECK-MAP-BULK  similar, but doesnt take quite as long.
; :CHECK-REVERSE-LEVEL-2-MAP-BULK  

; :PF    Interprets open register as LP-FEF Q of a PDL-FRAME, and prints
;	  the entire frame.
; :previous-active-frame  if the FEF word of a frame is open, open the previous active frame.
; :previous-open-frame    likewise, the previous open frame.
; :FLAGS  Decode M-FLAGS
; :INTOFF disable machine interrupts
; :INTON  Turn machine interrupts on.
; :tvintoff  turn off interrupts from TV.
; :tvinton   turn on interrupts from TV.
; arg :PHYS-MEM-WORD-SEARCH   Searches real core for arg  **CROCK** FOR NOW IT ONLY
;				SEARCHES 128K.  FIX WHEN LAM KNOWS ABOUT REAL MEM.
; :DESCRIBE  if last quantity typed is a closure or entity, prints CLOSURE-ALIST sort
;             of thing.  if a stack-group, prints info from stack group header.
; :DESCRIBE-LEXICAL-ENVIRONMENT
; :PCHECK    Use this to track down problems with hardware parity checkers.
;	   Types what the parity generator chips for the last quantity examined
;	   should put out.  Works for C-MEM ..add others.. .

;newer stuff:
; :with-output-to-file {filename colon-cmd}
;	after specifing the filename as a string, specify a colon command
;	as usual, and the any output printed will be sent both to the file and
;	to the screen.
; :select-speed  put up menu for selecting TRAM speed.
; :lam-iopb  print disk command block used by main ucode
; :debug-iopb  command block used by lam program itself
; :sdu-iopb
; :prom-iopb   used by prom
; :csm    print symbolic address of csm-adr
; :print-active-mapping-regs   print lambda-iopb, and mapping registers it addresses
; :eagle-initialize, initialize-disk-control
; :rg or :rg-mode, :dp or :dp-mode   prints respective mode registers.
; :mid   print symbols contents of mid addressed by last quan typed or arg.
; :select-symbols  put up a menu with various options.
; :dump-original-symbols
; :macro-break  insert a breakpoint into macrocode by smashing an instruction
; :macro-unbreak  remove macrocode breakpoint.  Seems to lose, look at this! RG
; :macro-restore  replace smashed instruction
; <arg>:macro-single-step  set (1) or clear (0) hardware single step mode flag.
; <n>:force-macro-return.  attempt to force n levels of macrocode subroutine return.
; :cold-boot  cold boot machine (after ucode loaded).  Writes memory configuration info.
; :cold-boot-and-load-symbols  load symbols while its cold-booting
; :cold-boot-setup    as in cold boot, but dont really start machine.  Does set up memory
;		configuration.
; :start-prom  transfer to PROM at location 36000 (or maybe 36001 in share mode).
; :chaos-meters  print out chaos meters of debugged machine
; :ether-meters  print out ethernet meters of debugged machine.
; :opc-search  search OPCs for a symbol you type.
; :summerize-opcs  (spelling due to PACE)
; :cache-on	turn on cache (hardware enable it, and set bit in a-l2-map-control-bits)
; :cache-on     turn off cache.  inverse of above.
; :print-unibus-channels
; :foothold  ??
; :int-level (explorer only)

; in CADRD:
;
; :START -  adr :START,   start machine, let it run
; :LOWLEVEL -  :LOWLEVEL T turns on low-level mode, in which reading most registers
;    gets what is currently in the machine rather than what is saved,
;    writing is unaffacted.  Makes the display at the bottom of the screen useful with :EX
;    :LOWLEVEL VERY enters a mode where LAM tries not to "spontaneously" affect the
;    hardware in any way.  This means only the "passive" machine state is available,
;    ie no saving - frobbing - restoring is permitted.  If random things not part of
;    the passive state are examined, etc, ideally the saving, etc should be done
;    at that time.  BE VERY CAREFUL 
; :MODE - Decodes the mode register symbolically
; :CHMODE - Edits the mode register
; :RESTORE -  does a full-restore, getting software state into hardware,
; :sm-step -  call SM-STEP program (minor cycle stepper)
; :select-test - call SELECT-TEST program (menu interfact to simple loop tests)
; :EX - Execute .IR once.
; :SCOPE causes the machine to execute whatever is in DEBUG-IR
;	 repeatedly at full speed.  Deposit in .IR just before doing this.

;
; Breakpoints:
; :B	set breakpoint at prefix arg or open location
; :UB	unset breakpoint at ..
; :LISTB  list breakpoints
; :UAB	unset all breakpoints
; :RB	reset all breakpoints (useful if they have been loaded over)
; :P	proceed
; :G    do 1@G and :P
; :TB	set temporary breakpoint at .. (temp bkpt goes away when reached)
; :TBP	set temporary breakpoint and proceed
; :RETURN-BREAK  Set breakpoint where current CALL instruction will return
; :US-BREAK  Set breakpoint at current open US stack locn, to top of US if no reg open.
; 
;Initial Symbols
; RESET VMA MWD RAIDR PSV FSV RUNNING TRYING-TO-RUN MODE
; LLMOD NOOPF FDEST FSRC .IR IR PC USP Q DC PP PI CIB OPC
;
;   Since there are many different memories in the machine, each having
;addresses running from 0 to some power of 2, a large space of register addresses
;is defined, and the various memories are assigned parts of it.
;A register address can be referred to either by specifying which memory
;and the address within the memory, as in 200@C for location 200 in control memory,
;or by specifying the register address, which would be 200+RACMO for that location.
;
;-400000<n<0      register address space, various memories etc.
;(minus 400000+n) physical main memory location n ("concatenated" locns)
;positive number n  virtual memory location n
;
;n@C	control memory
;n@D	dispatch memory
;n@P	PDL buffer
;n@1	map 1
;n@2C	map level 2 control bits
;n@2P   map level 2 physical page
;n@A	A memory
;n@U	micro return stack
;n@M	M memory
;FS n	functional sources
;FD n	functional destinations
;LAM n	"special" registers, e.g. PC, USP
;CSW n	CCONS control switches
;RAIDR n  Raid registers
;CIB n	Console inst buffers
;OPC n  Old PCs

;n@G	set PC
;@Q	last frob typed (like Q in DDT)
;
;_nn	rotate left nn places (32 bits).  follow by space or equals to type out.
;
;_A	type out as array header
;_B	type out as bytes (right to left)
;_D	type out as header
;_H	type out as halfwords LH,,RH
;_I	type out as macro instruction
;_Q	type out as lisp Q
;_S	type out as lisp machine S expression (ie do PRINT, sort of)
;	  LAM-SEXP-PRINLEVEL and LAM-SEXP-PRINLENGTH control how deep and
;	  how long things will go, respectively.
;_U	type out as micro instruction
;_V	type out as micro instruction, old style.
;_X	type out as hex
;__	type out as register address
;_#     type out as bit numbers of set bits.
;` (left slant) instead of _ causes type-in mode
;In type-in mode,  completes what has been typed so far
; as much as possible, ? lists possible completions, space
; terminates the syllable.  You can type just a space and
; if there is one possibility that types nothing in
; type-out mode, (i.e. a default) it will get used.
;
;' (right slant) is similar except typing just a space leaves
; the field set to its previous value.
; In the MODE register, bit 1.1=run slow, bit 1.2=disable error halts

(eval-when (compile)
  (SETQ INHIBIT-STYLE-WARNINGS-SWITCH T)) ;DON'T HASSLE ME ABOUT CALLING GETCHARN

(proclaim '(SPECIAL PAGE-SIZE LAM-REG-ADR-PHYS-MEM-OFFSET 
		    SG-NAME SG-REGULAR-PDL SG-AP RACMWD RACVMW RACPMW DESC DESC-STACK ITEM
		    LAM-FULL-SAVE-VALID LAM-PASSIVE-SAVE-VALID LAM-LOW-LEVEL-FLAG
		    *DONT-TOUCH-MACHINE*))
(proclaim '(SPECIAL QF-SWAP-IN-LOOP-CHECK))

(DEFVAR LAM-ACCESS-PATH NIL)	   ;If this a closure, send it messages from
				   ;LAM-REGISTER-EXAMINE, LAM-REGISTER-DEPOSIT.  used by
				   ;stuff that looks at UCODE-IMAGES

(proclaim '(SPECIAL LAM-SYMBOLS-NAME LAM-SYMBOLS-VALUE LAM-SYMBOLS-SIZE LAM-SYMBOLS-ARRAY-SIZE))
(SETQ LAM-SYMBOLS-ARRAY-SIZE 5000) ;CURRENT SIZE OF ARRAYS

;alist (<file-name> lam-symbols-size lam-symbols-name lam-symbols-value)
(DEFVAR LAM-SYMBOL-TABLES-LOADED NIL)

(defvar lam-raid-reg (make-array 8 :initial-element 0))

;(ARRAY LAM-RAID-REG FIXNUM 8)
;(FILLARRAY (FUNCTION LAM-RAID-REG) '(0))
;(DECLARE (ARRAY* (FIXNUM LAM-RAID-REG 8)))

(proclaim '(SPECIAL AREA-LIST %SYS-COM-PAGE-TABLE-PNTR %SYS-COM-PAGE-TABLE-SIZE
		    %SYS-COM-/#-AREAS))

; SPECIAL STATUS REGISTERS
;	RUNNING STATUS
;	ERROR STATUS
;	OUTPUT BUS READBACK

; FUNCTIONAL REGISTERS ("NORMAL" WAY OF ACCESSING THESE FCTNS IN PARENS)
;	RESET (CNTRL-R)
;	STEP  (CNTRL-N)
;	STOP  (CNTRL-S)
;	SET STARTING ADR (@G)
;	GO (CNTRL-P, BUT KEEP LISTENING)

(proclaim '(SPECIAL 
	     %%ARRAY-LEADER-BIT %%ARRAY-INDEX-LENGTH-IF-SHORT
	     %%ARRAY-LONG-LENGTH-FLAG 
	     %%M-FLAGS-QBBFL))

(DEFVAR LAM-LAST-OPEN-REGISTER NIL)

(proclaim '(SPECIAL LAM-FIRST-STATUS-LINE LAM-UPDATE-DISPLAY-FLAG
		    LAM-LAST-VALUE-TYPED
		    LAM-BREAKPOINT-LIST
		    LAM-TEMPORARY-BREAKPOINT-LIST
		    LAM-OPEN-REGISTER LAM-GETSYL-UNRCH LAM-GETSYL-UNRCH-TOKEN))

(DEFUN TYI-UPPERCASIFY () (CHAR-UPCASE (TYI *STANDARD-INPUT*)))


;;;MICRO-LOADER

(DEFVAR LAM-FILE-SYMBOLS-LOADED-FROM NIL)

(DEFUN LAM-LOAD-PROM (&OPTIONAL (CHECK NIL))
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (format *terminal-io* "~%Running INITIALIZE-LAMBDA-AND-MEMORIES")
	 (format *proc* "AInitialize CRAM-ADR-MAP and main memories~%")
	 (initialize-lambda-and-memories)
	 (format *terminal-io* "~%Telling SDU to load PROM")
	 (format *proc* "ALoading PROM~%")
	 (send *proc* :string-out "0u")
	 (send *proc* :read-32)
	 (format *terminal-io* "~%PROM loading complete"))
	(t
	 (LAM-LOAD-UCODE *lam-prom-direct-file* NIL CHECK))))

(DEFUN LAM-LOAD-PROM-SYMBOLS NIL
   (LAM-UCODE-LOADER 'LOAD-SYMBOLS *lam-prom-direct-file*
		     NIL))

(DEFVAR UCODE-FILE-DEFAULTS NIL)

(DEFUN LAM-LOAD-UCODE (&OPTIONAL FILE MERGEP CHECK &AUX TRUENAME)
  (COND ((NULL UCODE-FILE-DEFAULTS)
	 (SETQ UCODE-FILE-DEFAULTS (FS:MAKE-PATHNAME-DEFAULTS))
	 (FS:MERGE-AND-SET-PATHNAME-DEFAULTS "sys:lambda-ucode;bootstrap lam-uload"
					     UCODE-FILE-DEFAULTS)))
  (SETQ FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS (OR FILE "") UCODE-FILE-DEFAULTS "LAM-ULOAD")
	TRUENAME (SEND FILE :TRUENAME))
  (FORMAT T "~&PROCESSING FILE ~A" TRUENAME)
  (LAM-UCODE-LOADER (IF CHECK 'COMPARE NIL) FILE MERGEP)
  (LAM-RECORD-SYMBOL-TABLE TRUENAME)
  (SETQ LAM-FILE-SYMBOLS-LOADED-FROM FILE)	;OLDER, LOSING HACK
  )

(DEFUN LAM-LOAD-BOOTSTRAP (FILE)
  (LAM-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL))

(DEFUN LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION (&OPTIONAL VERSION BASE-FN)
  (IF (NULL BASE-FN)
      (setq base-fn (base-filename-for-version version)))
  (IF (NULL VERSION)
      (LAM-LOAD-NEW-LAMBDA-SYMBOLS)
    (LAM-LOAD-UCODE-SYMBOLS (SEND (FS:PARSE-PATHNAME BASE-FN)
				  :NEW-PATHNAME
				  :type (cond ((eq current-processor-type :lambda) "LMC-SYM")
					      ((eq current-processor-type :explorer) "EMC-SYM"))
				  :version VERSION))))

;; Copied from LAD: RELEASE-3.LAMBDA-DIAG; LAM.LISP#91 on 2-Oct-86 17:53:21
(defun base-filename-for-version (version)
  (let ((path (fs:translated-pathname "sys:ubin;ulambda")))
    (if (< version 1200.)
	(send path :new-directory '("QL" "UBIN"))
      path)))

(DEFUN LAM-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP &AUX TRUENAME)
  (IF (NULL FILE)
      (LAM-LOAD-NEW-LAMBDA-SYMBOLS)
    (SETQ FILE (FS:MERGE-PATHNAME-DEFAULTS FILE)
	  TRUENAME (SEND FILE :TRUENAME))
    (COND ((EQ TRUENAME LAM-FILE-SYMBOLS-LOADED-FROM))
	  ((AND (NULL MERGEP)
		(LAM-SELECT-SYMBOL-TABLE TRUENAME)))
	  (T
	   (LAM-UCODE-LOADER 'LOAD-SYMBOLS TRUENAME MERGEP)
	   (LAM-RECORD-SYMBOL-TABLE TRUENAME)))))

(DEFUN (:PROPERTY SELECT-SYMBOLS LAM-COLON-CMD) (&OPTIONAL IGNORE)
  (select-symbols)
  (FORMAT T "~%done.~%"))

(defun lam-dont-use-symbols ()
  (lam-initialize-symbol-table nil lam-initial-syms)
  (setq lam-file-symbols-loaded-from nil)
  (lam-record-symbol-table nil))


(DEFUN SELECT-SYMBOLS NIL
  (LET ((TRUENAME (TV:MENU-CHOOSE
		    (APPEND '(NONE NEW-LAMBDA-SYMBOLS PROMPT-FOR-VERSION
				   NEW-99-SYMBOLS 99-SYMBOLS-PROMPT-FOR-VERSION
				   new-104-symbols 104-symbols-prompt-for-version)
			    (MAPCAR (FUNCTION CAR) LAM-SYMBOL-TABLES-LOADED)))))
    (cond (truename
	   (selectq truename
	     (none 
	      (LAM-INITIALIZE-SYMBOL-TABLE NIL LAM-INITIAL-SYMS)
	      (SETQ LAM-FILE-SYMBOLS-LOADED-FROM NIL)
	      (LAM-RECORD-SYMBOL-TABLE NIL))
	     (new-lambda-symbols
	      (LAM-LOAD-NEW-LAMBDA-SYMBOLS))
	     (NEW-99-SYMBOLS
	      (LAM-LOAD-UCODE-SYMBOLS
		(LAM-LMC-SYM-FILE-PATHNAME *LAM-UCODE-99-BASE-FILENAME*)))
	     (new-104-symbols
	      (lam-load-ucode-symbols
		(lam-lmc-sym-file-pathname *lam-ucode-104-base-filename*)))
	     ((prompt-for-version 99-SYMBOLS-PROMPT-FOR-VERSION 104-symbols-prompt-for-version)
	      (format t "~&Type desired version number (in decimal): ")
	      (let ((vers (let ((*read-base* 10.)) (read))))
		(lam-load-ucode-symbols-for-version
		  vers
		  (SELECTQ TRUENAME
		    (PROMPT-FOR-VERSION *lam-ucode-base-filename*)
		    (99-SYMBOLS-PROMPT-FOR-VERSION *LAM-UCODE-99-BASE-FILENAME*)
		    (104-symbols-prompt-for-version *lam-ucode-104-base-filename*)))))
	     (otherwise
	      (LAM-SELECT-SYMBOL-TABLE TRUENAME)))))))


  

(DEFUN LAM-LOAD-NEW-LAMBDA-SYMBOLS NIL
    (LAM-LOAD-UCODE-SYMBOLS (lam-lmc-sym-file-pathname *lam-ucode-base-filename*)))

(defun lam-lmc-sym-file-pathname (file)
  (LET ((PATHNAME (FS:PARSE-PATHNAME FILE)))
    (SEND PATHNAME :NEW-TYPE (cond ((eq current-processor-type :lambda) "LMC-SYM")
				   ((eq current-processor-type :explorer) "EMC-SYM")))))

(DEFUN LAM-COMPARE-UCODE (FILE)
  (LAM-UCODE-LOADER 'COMPARE FILE NIL))

;; Copied from LAD: RELEASE-3.LAMBDA-DIAG; LAM.LISP#91 on 2-Oct-86 17:53:23
(DEFUN ASSURE-LAM-SYMBOLS-LOADED (&optional (queryp nil))
  (si:select-processor
    (:lambda
      (when (not (eq current-processor-type :lambda))
	(lambda-mode))
      (LET ((CURRENT-VERSION (AND LAM-FILE-SYMBOLS-LOADED-FROM
				  (SEND LAM-FILE-SYMBOLS-LOADED-FROM :VERSION))))
	(when (and (NEQ CURRENT-VERSION %MICROCODE-VERSION-NUMBER)
		   (or (null queryp)
		       (format:y-or-n-p-with-timeout 1800. NIL "Do you wish to load LAM symbols for Lambda? ")))
	  (FORMAT T "~%Loading LAM symbols for ULAMBDA version ~D~%"
		  %MICROCODE-VERSION-NUMBER)
	  (SI:WITH-SYS-HOST-ACCESSIBLE
	    (LET ((*READ-BASE* 8.))
	      (PKG-BIND "LAMBDA"
		(LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION %MICROCODE-VERSION-NUMBER))))))
      )
    (:explorer
      (when (not (eq current-processor-type :explorer))
	(explorer-mode))
      (LET ((CURRENT-VERSION (AND LAM-FILE-SYMBOLS-LOADED-FROM
				  (SEND LAM-FILE-SYMBOLS-LOADED-FROM :VERSION))))
	(when (and (NEQ CURRENT-VERSION %MICROCODE-VERSION-NUMBER)
		   (or (null queryp)
		       (format:y-or-n-p-with-timeout 1800. NIL "Do you wish to load LAM symbols for Lambda//E? ")))
	  (FORMAT T "~%Loading LAM symbols for ULAMBDA//E version ~D~%"
		  %MICROCODE-VERSION-NUMBER)
	  (SI:WITH-SYS-HOST-ACCESSIBLE
	    (LET ((*READ-BASE* 8.))
	      (PKG-BIND "LAMBDA"
		(LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION %MICROCODE-VERSION-NUMBER))))))
      )
      (:cadr)))



(DEFUN LAM (&OPTIONAL flush-state)		;MAIN LOOP OF LAMBDA CONSOLE PROGRAM
  (if flush-state (flush-state))
  (ERROR-RESTART (dbg:debugger-condition "Restart LAM from top level")
    (PROG ((*READ-BASE* 8.) (*PRINT-BASE* 8.) (*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA"))
	   LAM-ARG LAM-SYL LAM-VAL LAM-UPDATE-DISPLAY-FLAG LAM-OPEN-REGISTER 
	   LAM-LAST-OPEN-REGISTER LAM-LAST-VALUE-TYPED COM-CH TEM)
	  (SETQ QF-SWAP-IN-LOOP-CHECK NIL)
	  (LAM-CONSOLE-INIT)
	  (format *terminal-io* "~&~:[Getting fresh state from machine~;~
				    LAM contains saved state, use (LAM T) to flush it~].~%"
		  lam-full-save-valid)
	  (if (typep *terminal-io* 'tv:window)
	      (LAM-CONSOLE-STATUS-DISPLAY T))	;dont touch machine since saved state may
						;not be valid
	  (cond ((null *his-version*)
		 (format t "~%Setting up for his version ..")
		 (qf-initial-area-list)
		 (format t "  = ~d~%" *his-version*)))
       L0
	  (SETQ LAM-ARG NIL)
	  (IF (and (typep *terminal-io* 'tv:window)
		   (>= (- (CAR (CURSORPOS)) LAM-FIRST-STATUS-LINE) 0))
	      (PROGN (CURSORPOS 'Z) (TERPRI)))
       L
	  (SETQ LAM-SYL (LAM-GETSYL-READ-TOKEN))
	  (COND ((NUMBERP LAM-SYL)
		 (GO L1))
		((EQ LAM-SYL '*RUB*)		;OVER RUB-OUT
		 (GO ERR1))
		((EQ LAM-SYL '|#@|)		;VARIOUS REG ADDR SPACES + MISC COMMANDS
		 (GO COM))
		((EQ LAM-SYL '|#ALTMODE|)	;EXIT TO LISP
		 (GO X))
		((EQ LAM-SYL '|#_|)		;VARIOUS TYPE-OUT MODES
		 (GO UND))
		((EQ LAM-SYL '|#`|)		;VARIOUS TYPE-IN MODES
		 (GO IND))
		((EQ LAM-SYL '|#'|)		;TYPE-IN OVER EXISTING FIELDS
		 (GO INDOV))
		((EQ LAM-SYL '|.|)		;"POINT"
		 (SETQ LAM-SYL LAM-LAST-OPEN-REGISTER)
		 (GO L1))
		((EQ LAM-SYL '|#:|)		;VARIOUS SYMBOLIC COMMANDS
		 (GO CLN))
		((SETQ TEM (LAM-LOOKUP-NAME LAM-SYL))
		 (SETQ LAM-SYL TEM)
		 (GO L1)))
       L2
	  (COND ((SETQ TEM (GET LAM-SYL 'LAM-COMMAND))
		 (GO COM1)))
       ERR
	  (PRIN1 LAM-SYL)
       ERR1
	  (PRINC "??  ")
	  (GO L0)
	  
       L1
	  (COND ((NUMBERP LAM-ARG)
		 (SETQ LAM-ARG (PLUS LAM-ARG LAM-SYL)))
		(T (SETQ LAM-ARG LAM-SYL)))
	  (GO L)
	  
       COM
	  (SETQ COM-CH (LAM-GETSYL-READ-TOKEN T))	; (ASCII (LAM-CHAR-UPCASE (LAM-GETSYL-RCH)))
	  (COND ((SETQ TEM (GET COM-CH 'LAM-LOWEST-ADR))
		 (COND ((NULL LAM-ARG) (SETQ LAM-ARG 0)))
		 (SETQ LAM-ARG (+ LAM-ARG (SYMEVAL TEM)))
		 (GO L)))
	  (SETQ LAM-SYL COM-CH)
	  (GO L2)
       COM1
	  (SETQ LAM-VAL (FUNCALL TEM LAM-ARG))
	  (COND (LAM-UPDATE-DISPLAY-FLAG 
		 (LAM-CONSOLE-STATUS-DISPLAY NIL)
		 (SETQ LAM-UPDATE-DISPLAY-FLAG NIL)))
	  (COND ((NUMBERP LAM-VAL)
		 (SETQ LAM-ARG LAM-VAL)
		 (GO L))
		(T (GO L0)))
	  
       UND
	  (SETQ LAM-SYL (CHAR-UPCASE (LAM-GETSYL-RCH)))	;VARIOUS TYPEOUT COMMANDS
	  (OR LAM-ARG (SETQ LAM-ARG LAM-LAST-VALUE-TYPED))
	  (COND ((OR (AND (>= LAM-SYL #/0) (<= LAM-SYL #/9))
		     (= LAM-SYL #/-))
		 (SETQ LAM-GETSYL-UNRCH LAM-SYL	;IF DIGIT OR MINUS,
		       LAM-SYL (LAM-GETSYL-READ-TOKEN))	;READ WHOLE NUMBER
		 (SETQ LAM-SYL (LOGAND 37 LAM-SYL))	;AND LEFT-ROTATE BY THAT
		 (SETQ LAM-ARG
		       (LOGIOR (LOGLDB (+ LAM-SYL (ASH (- 40 LAM-SYL) 6)) LAM-ARG)
			       (ASH (LOGLDB (- 40 LAM-SYL) LAM-ARG) LAM-SYL)))
		 (AND (EQ LAM-GETSYL-UNRCH-TOKEN #\SPACE)
		      (SETQ LAM-GETSYL-UNRCH-TOKEN '=))
		 (GO L)))			;N_N<SPACE> TYPES OUT, OTHERWISE IS TYPE-IN!
	  (tyo #/space)
	  (OR (SETQ COM-CH (ASSQ (SETQ LAM-SYL (ASCII LAM-SYL))
				 LAM-MODE-DESC-TABLE))
	      (GO ERR))
	  (LAM-TYPE-OUT LAM-ARG (CDR COM-CH) T NIL)
	  (SETQ LAM-LAST-VALUE-TYPED LAM-ARG)	
	  (PRINC "  ")
	  (GO L0)
	  
       IND
	  (SETQ LAM-SYL (ASCII (CHAR-UPCASE (LAM-GETSYL-RCH))))	;VARIOUS TYPEIN COMMANDS
	  (PRINC " ")
	  (OR (SETQ COM-CH (ASSQ LAM-SYL LAM-MODE-DESC-TABLE))
	      (GO ERR))
	  (SETQ LAM-SYL (LAM-TYPE-IN (CDR COM-CH) 0 NIL))
	  (GO L1)
	  
       INDOV
	  (SETQ LAM-SYL (ASCII (CHAR-UPCASE (LAM-GETSYL-RCH))))
	  (FORMAT T "~%[Edit] ")
	  (OR (SETQ COM-CH (ASSQ LAM-SYL LAM-MODE-DESC-TABLE))
	      (GO ERR))
	  (SETQ LAM-SYL (LAM-TYPE-IN (CDR COM-CH) LAM-LAST-VALUE-TYPED T))
	  (GO L1)
	  
       X
	  (RETURN LAM-LAST-VALUE-TYPED)
	  
      CLN
	 (SETQ LAM-SYL (LAM-GETSYL-READ-TOKEN))	;:FOOBAR ETC.
	 (OR (SETQ TEM (GET LAM-SYL 'LAM-COLON-CMD))
	     (GO ERR1))
	 (GO COM1))))

(DEFUN LAM-CHAR-UPCASE (CHAR)
  (DECLARE (FIXNUM CHAR))
  (CHAR-INT (CHAR-UPCASE (INT-CHAR CHAR))))

(DEFUN LAM-CONSOLE-STATUS-DISPLAY (DONT-TOUCH-MACHINE &AUX SAVE-CURSOR-POS PC IR)
  (SETQ SAVE-CURSOR-POS (CURSORPOS))
  (send *standard-output* :set-cursorpos 0 LAM-FIRST-STATUS-LINE :character)
  (SEND *STANDARD-OUTPUT* :CLEAR-REST-OF-WINDOW)
  (SEND *STANDARD-OUTPUT* :LINE-OUT "***********************************************")
  (LAM-ENTER)
  (FORMAT T "PC=~O   " (SETQ PC (LAM-REGISTER-EXAMINE RAPC)))
  (SETQ IR (LAM-REGISTER-EXAMINE RASIR))
  (FORMAT T "MFO=~O   ~A~%IR="
	  (LAM-REGISTER-EXAMINE RAMFO)
	  (LAM-FIND-CLOSEST-SYM (+ PC RACMO)))	;PRINT SYMBOLIC PC
  ;if coming in at top level, dont print contents of M or A mem location that does
  ;not have symbolic name.  Problem is that examining does LAM-NOOP-CLOCK which results
  ;in loss of state, increments PC, etc etc.
  (LAM-TYPE-OUT IR LAM-UINST-DESC T DONT-TOUCH-MACHINE)
  (FORMAT T "~%~:[~;NOOP ~]~:[~;LAST-INST-HAD-HALT-BIT~]"
	  LAM-NOOP-FLAG
	  lam-last-inst-had-halt-bit)
  ;(PRINC "ERROR-STATUS ")
  ;(LAM-PRINT-ERROR-STATUS  (LAM-REGISTER-EXAMINE RASTS))
  ;(DBG-PRINT-STATUS)	;PRINT UNIBUS, XBUS  PARERRS, NXM
  (TERPRI)
  (LAM-RAID)
  ;print cache state machine state
  (if (eq current-processor-type :lambda)
      (let ((tem (read-csm-adr)))
	(format t "~%csmadr: ~o  ~s" TEM (CSM-SYMBOLIC-LOCATION (LOGAND 3777 TEM)))))
  
  (CURSORPOS (CAR SAVE-CURSOR-POS) (CDR SAVE-CURSOR-POS))	;RESTORE CURSOR POS
  ;(IF (LAM-MN-MEM-PAR-P)
  ;    (FORMAT T "~%There is a main memory parity error.~%"))
  )

(DEFUN LAM-PRINT-SET-BITS (NUM BIT-LIST)
  (PROG (BIT-NUM THIS-BIT-SET FIELD)
	(SETQ BIT-NUM 0)
     L
	(COND ((OR (= 0 NUM)
		   (NULL BIT-LIST))
		(RETURN T)))
	(SETQ FIELD  (+ (LSH BIT-NUM 6) 0001))
	(SETQ THIS-BIT-SET (NOT (= 0 (LOGLDB FIELD NUM))))
	(COND ((NULL (CAR BIT-LIST))
	       (GO NEXT))
	      ((NOT (ATOM (CAR BIT-LIST)))
	       (COND ((NUMBERP (CAAR BIT-LIST))
		      (SETQ FIELD (DPB (CAAR BIT-LIST) 0006 FIELD))
		      (PRINC (NTH (LDB FIELD NUM) (CDAR BIT-LIST)))
		      (tyo #/space))
		     ((EQ (CAAR BIT-LIST) 'ENABLE-FIELD)
		      (LET ((FIELD-CONTENTS (LOGLDB (CADDAR BIT-LIST) NUM))
			    (BITS (LDB 0006 (CADDAR BIT-LIST))))
			(DOLIST (OP (CDDDAR BIT-LIST))
			  (IF (EQ OP 'SIGN-EXTEND)
			      (IF (BIT-TEST (LSH 1 (1- BITS))
					    FIELD-CONTENTS)
				  (SETQ FIELD-CONTENTS (LOGDPB FIELD-CONTENTS
							       BITS
							       -1)))
			    (SETQ FIELD-CONTENTS (FUNCALL OP FIELD-CONTENTS))))
			(COND (THIS-BIT-SET
			       (PRINC (LIST (CADAR BIT-LIST) FIELD-CONTENTS))
			       (SETQ NUM (LOGDPB 0 (CADDAR BIT-LIST) NUM))))))
		     ((FUNCALL (CAAR BIT-LIST) THIS-BIT-SET)
		      (PRIN1 (CADAR BIT-LIST))
		      (tyo #/space))))
	      (THIS-BIT-SET (PRIN1 (CAR BIT-LIST))
			    (tyo #/space)))
     NEXT
	(SETQ NUM (LOGDPB 0 FIELD NUM))
	(SETQ BIT-NUM (+ BIT-NUM (LDB 0006 FIELD)))
	(SETQ BIT-LIST (CDR BIT-LIST))
	(GO L)))


(DEFUN LAM-STORE (REG-ADR QUAN)
   (COND ((EQ 'RAIDR (LAM-FIND-REG-ADR-RANGE REG-ADR))
	  (aset QUAN LAM-RAID-REG (- REG-ADR RARDRO)))
	 (T (LAM-REGISTER-DEPOSIT REG-ADR QUAN))))

(DEFUN LAM-RAID ()
  (DO ((I 0 (1+ I))
       (TEM)
       (LAM-LAST-VALUE-TYPED))
      ((= I 8))
    (COND ((NOT (ZEROP (SETQ TEM (aref LAM-RAID-REG I))))
	   (LAM-PRINT-ADDRESS TEM)
	   (PRINC "//   ")
	   (LAM-PRINT-REG-ADR-CONTENTS TEM)
	   (SETQ TEM (CURSORPOS))
	   (COND ((< (CDR TEM) 40.)
		  (CURSORPOS (CAR TEM) 40.))
		 ((TERPRI))) ))))

(DEFF (:PROPERTY /#// LAM-COMMAND) 'LAM-SLASH)

(DEFUN LAM-SLASH (ADR)
  (cond ((null adr)
	 nil)
	(t
	 (SETQ LAM-OPEN-REGISTER ADR)
	 (SETQ LAM-LAST-OPEN-REGISTER LAM-OPEN-REGISTER)
	 (PRINC "   ")
	 (let ((range (lam-find-reg-adr-range adr)))
	   (selectq range
	     (opc
	      (let ((pc (logand (lam-register-examine adr)
				(selectq (send *proc* :proc-type)
				  (:lambda 177777)
				  (:explorer 37777)))))
		(lam-print-address (+ pc racmo))
		(format t "   ")
		(cond ((eq (send *proc* :proc-type) :explorer)
		       (let* ((next-opc  (lam-register-examine (max (1- adr) raopco)))
			      (jump-taken (not (ldb-test (byte 1 14.) next-opc)))
			      (nooped (not (ldb-test (byte 1 15.) next-opc))))
			 (cond ((= adr raopco)
				(format t "{?}"))
			       ((or jump-taken nooped)
				(format t "{")
				(if jump-taken (format t "J"))
				(if nooped (format t "N"))
				(format t "}"))))))
		(lam-print-reg-adr-contents (+ pc racmo))))
	     (d
	      (LAM-PRINT-REG-ADR-CONTENTS ADR)
	      (let ((exp-p (eq (send *proc* :proc-type) :explorer)))
		(format t "   ~[.~;N~]~[.~;P~]~[.~;R~] "
			(ldb (if exp-p rav-disp-n-bit lam-disp-n-bit) lam-last-value-typed)
			(ldb (if exp-p rav-disp-p-bit lam-disp-p-bit) lam-last-value-typed)
			(ldb (if exp-p rav-disp-r-bit lam-disp-r-bit) lam-last-value-typed))
		(lam-print-address (+ racmo (ldb (if exp-p rav-disp-pc-bits lam-disp-pc-bits)
						 lam-last-value-typed)))
		(format t " ")))
	     (t
	      (LAM-PRINT-REG-ADR-CONTENTS ADR)
	      
	      ))))))

(DEFF (:PROPERTY /#RETURN LAM-COMMAND) 'LAM-CR)

(DEFUN LAM-CR (QUAN)
  (COND ((AND QUAN LAM-OPEN-REGISTER)
	 (LAM-STORE LAM-OPEN-REGISTER QUAN)))
  (SETQ LAM-OPEN-REGISTER NIL)
  (TERPRI))

(DEFF (:PROPERTY /#LINE LAM-COMMAND) 'LAM-LF)

(DEFUN LAM-LF (QUAN &AUX TEM)
  (LAM-CR QUAN)
  (LAM-PRINT-ADDRESS (SETQ TEM (1+ LAM-LAST-OPEN-REGISTER)))
  (tyo #//)
  (LAM-SLASH TEM)
  NIL)

(DEFUN (:PROPERTY /#^ LAM-COMMAND) (QUAN &AUX TEM)
  (LAM-CR QUAN)
  (LAM-PRINT-ADDRESS (SETQ TEM (1- LAM-LAST-OPEN-REGISTER)))
  (tyo #//)
  (LAM-SLASH TEM)
  NIL)

(DEFUN (:PROPERTY /#SPACE LAM-COMMAND) (ARG) ARG)
(DEFUN (:PROPERTY /#+ LAM-COMMAND) (ARG) ARG)

(DEFUN (:PROPERTY /#PAGE LAM-COMMAND) (QUAN)
  QUAN
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  NIL)

(DEFUN (:PROPERTY /#=  LAM-COMMAND) (QUAN)
  (AND QUAN (SETQ LAM-LAST-VALUE-TYPED QUAN))
  (PRIN1 LAM-LAST-VALUE-TYPED)
  (PRINC "   ")
  NIL)

(DEFF (:PROPERTY G LAM-COMMAND) 'LAM-GO)

(DEFUN LAM-GO (QUAN)
  (COND ((MINUSP QUAN) (SETQ QUAN (- QUAN RACMO))))
  (LAM-REGISTER-DEPOSIT RASA QUAN)
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (TERPRI)
  NIL)

(DEFF (:PROPERTY /#CONTROL-N LAM-COMMAND) 'LAM-STEP)

(DEFUN (:PROPERTY /#HYPER-N LAM-COMMAND) (QUAN)
  (LET ((QN (OR QUAN 1)))
    (IF (> QN 1)
	(PROGN (BEEP)
	       (FORMAT T "~% HYPER-N DOEST TAKE AN ARGUMENT. JUST SINGLE STEPPING"))
      (LAM-STEP NIL ':AND-DONT-TOUCH T))))

(DEFUN LAM-STEP (QUAN &OPTIONAL &KEY (AND-DONT-TOUCH NIL))
  (IF AND-DONT-TOUCH
      (PROGN
        (IF (LDB-TEST LAM-IR-HALT LAM-SAVED-IR)
	    (SETQ LAM-SAVED-IR
		  (COMPUTE-PARITY-64 (DPB 0 LAM-IR-HALT LAM-SAVED-IR))))
	(LAM-FULL-RESTORE)
	(ENABLE-LAMBDA-SINGLE-STEPPING T)
	(CHANGE-PMR '(ADVANCE-UINST-REQUEST 0))
	(CHANGE-PMR '(ADVANCE-UINST-REQUEST 1)))
    (LET ((QN (OR QUAN 1)))
      (LAM-REGISTER-DEPOSIT RASTEP QN)
      (SETQ LAM-UPDATE-DISPLAY-FLAG T)
      (AND QUAN (TERPRI))
      (SETQ LAM-OPEN-REGISTER NIL)
      NIL)))

(DEFUN (:PROPERTY AUTO-STEP LAM-COLON-CMD) (IGNORE)
  (DO () (())
    (LAM-REGISTER-DEPOSIT RASTEP 1)
    (LAM-CONSOLE-STATUS-DISPLAY NIL)
    (IF (SEND *TERMINAL-IO* :LISTEN)
	(RETURN NIL))))

(DEFF (:PROPERTY /#CONTROL-R LAM-COMMAND) 'LAM-RESET)

(DEFUN LAM-RESET (QUAN)
  (LAM-REGISTER-DEPOSIT RARS (OR QUAN 0))
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (TERPRI)
  NIL)

(DEFUN (:PROPERTY Q LAM-COMMAND) (QUAN)
  (PLUS (OR QUAN 0) LAM-LAST-VALUE-TYPED))

(DEFUN (:PROPERTY /#control-l lam-command) (ignore)
  (send *standard-output* :clear-window)
  (setq lam-update-display-flag t))

(defvar *recorded-accumulator-state*)
(defvar *recordable-accumulators*
	'(m-zr m-a m-b m-c m-d m-e m-t m-r m-q m-i m-j m-s m-k m-ap m-1 m-2 m-3 m-4 m-tem))

(defun read-accumulator-state ()
  (mapcar #'lam-symbolic-examine-register *recordable-accumulators*))	  

(defun (:property record-accumulator-state lam-colon-command) ()
  (setq *recorded-accumulator-state* (read-accumulator-state)))

(defun (:property compare-accumulator-state lam-colon-command) ()
  (let ((current-state (read-accumulator-state)))
    (if (equal current-state *recorded-accumulator-state*)
	(format t "~&Accumulators haven't changed.")
      (loop for old in *recorded-accumulator-state*
	    for new in current-state
	    for sym in *recordable-accumulators*
	    unless (equal old new)
	    do (format t "~&~A changed from ~A to ~A" sym old new)))))


(DEFF (:PROPERTY /#CONTROL-S LAM-COMMAND) 'LAM-STOP)

(DEFUN LAM-STOP (QUAN)
  (SETQ LAM-PASSIVE-SAVE-VALID NIL)
  (SETQ LAM-FULL-SAVE-VALID NIL)		;ASSURE READING FRESH STUFF FROM HARDWARE
  (LAM-REGISTER-DEPOSIT RASTOP QUAN)
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (QF-CLEAR-CACHE NIL)
  (TERPRI) )

(DEFF (:PROPERTY /#CONTROL-P  LAM-COMMAND) 'LAM-PROCEED)

(defun (:property /#meta-p lam-command) (&rest ignore)
  (LET* ((USP (LAM-REGISTER-EXAMINE RAUSP))
	 (TOP-RETURN (LAM-REGISTER-EXAMINE (+ USP RAUSO))))
    (LAM-SET-BREAKPOINT (+ RACMO TOP-RETURN) nil))
  (lam-proceed nil))

(defun (:property /#HYPER-P LAM-COMMAND) (QUAN)
  (LAM-SET-CHECK-PARITY QUAN)
  (lam-proceed nil ':and-dont-touch t))

(DEFUN LAM-PROCEED (QUAN &optional &key (and-dont-touch nil))
  (cond (AND-DONT-TOUCH
	 (IF (LDB-TEST LAM-IR-HALT LAM-SAVED-IR)
	     (SETQ LAM-SAVED-IR
		   (COMPUTE-PARITY-64 (DPB 0 LAM-IR-HALT LAM-SAVED-IR))))
	 (LAM-FULL-RESTORE)
	 (enable-lambda-and-nu-master ':AND-DONT-TOUCH T)
	 (format t "~&Running..."))
	(t (LAM-SET-CHECK-PARITY QUAN)
	   (QF-CLEAR-CACHE NIL)			;CLEAR PHT CACHE
	   (LAM-REGISTER-DEPOSIT RAGO 0)
	   (LAM-CONTROL-P-WAIT))))

(defvar *lam-control-p-wait-status*)

(DEFUN LAM-CONTROL-P-WAIT-lambda (&OPTIONAL (MSG  "Stop or Input"))
  (PRINC "--RUN--")
  (setq *lam-control-p-wait-status* nil)
  (PROCESS-WAIT MSG
		#'(LAMBDA (STREAM &aux halted-p)
		    (cond ((send stream ':listen)
			   (setq *lam-control-p-wait-status* 'typein)
			   t)
			  ((null (access-path-lmi-serial-protocol *proc*))
			   (condition-case (condition)
			       (setq halted-p (ldb-test halt-request-bit (read-con-reg)))
			     (:no-error
			      (setq *lam-control-p-wait-status* (if halted-p 'halted nil)))
			     (nubus-timeout
			      (setq *lam-control-p-wait-status* condition)
			      t)))
			  (t
			   (send *proc* :listen))))
		*TERMINAL-IO*)
  (IF (SEND *STANDARD-INPUT* :LISTEN)
      (SEND *STANDARD-INPUT* :TYI))
  (cond ((errorp *lam-control-p-wait-status*)
	 (ferror "error in control-p-wait: ~a"
		 (send *lam-control-p-wait-status* ':report nil))))
  (PRINC "STOP")
  (LAM-REGISTER-DEPOSIT RASTOP 0)
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (TERPRI) )

(DEFUN LAM-CONTROL-P-WAIT-explorer (&OPTIONAL (MSG  "Stop or Input"))
  (PRINC "--RUN--")
  (setq *lam-control-p-wait-status* nil)
  (do-forever
    (cond ((not (spi-running-p))
	   (setq *lam-control-p-wait-status* 'halted)
	   (return)))
    (cond ((send *terminal-io* :listen)
	   (setq *lam-control-p-wait-status* 'typein)
	   (return)))
    (process-wait msg
		  #'(lambda (stream initial-time)
		      (or (send stream :listen)
			  (> (time-difference (%microsecond-time) initial-time)
			     500000.)))
		  *terminal-io* (%microsecond-time)))
  (IF (SEND *STANDARD-INPUT* :LISTEN)
      (SEND *STANDARD-INPUT* :TYI))
  (cond ((errorp *lam-control-p-wait-status*)
	 (ferror "error in control-p-wait: ~a"
		 (send *lam-control-p-wait-status* ':report nil))))
  (PRINC "STOP")
  (LAM-REGISTER-DEPOSIT RASTOP 0)
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (TERPRI) )

(defun lam-control-p-wait (&rest args)
  (apply (ecase current-processor-type
	   (:lambda 'lam-control-p-wait-lambda)
	   (:explorer 'lam-control-p-wait-explorer))
	 args))

(DEFUN (:PROPERTY /#control-t lam-command) (ignore)
  (qf-clear-cache nil)
  (lam-register-deposit rago 0)
  (format t "--RUN--")
  (lambda-connect)
  (format t "~&STOP~&")
  (lam-register-deposit rastop 0)
  (setq lam-update-display-flag t))

(DEFUN (:PROPERTY /#TAB LAM-COMMAND) (QUAN &AUX TEM)
  (LAM-CR NIL)					;DON'T CLOBBER OPEN REGISTER
  (SETQ TEM (QF-POINTER (OR QUAN LAM-LAST-VALUE-TYPED)))
  (LAM-PRINT-ADDRESS TEM)
  (tyo #//)
  (LAM-SLASH TEM)
  NIL)

(DEFUN (:PROPERTY FOOBAR LAM-COMMAND) (QUAN)
  (COND ((EQUAL QUAN 105)
	 (cond ((eq (send *proc* :proc-type) :explorer)
		(spi-cold-boot)
		(lam-control-p-wait))
	       (t
		(LAM-REGISTER-DEPOSIT RARS 0)
		(LAM-GO 1)
		(LAM-PROCEED NIL))))
	(T (PRINC "FOOBAR??  ") NIL)))


;;;HIGHER LEVEL STUFF

(DEFUN LAM-REGISTER-EXAMINE-FIXNUM (ADR)
  (LET ((CONTENTS (LAM-REGISTER-EXAMINE ADR)))
    (OR (= (LOGLDB %%QF-DATA-TYPE CONTENTS) DTP-FIX)
	(ERROR (LIST ADR CONTENTS) 'SHOULD-BE-Q-FIXNUM 'FAIL-ACT))
    (LOGAND 77777777 CONTENTS) ))

(DEFUN LAM-REGISTER-EXAMINE-PTR (ADR)
  (LOGAND 77777777 (LAM-REGISTER-EXAMINE ADR)))

(DEFUN LAM-SYMBOLIC-EXAMINE-REGISTER (REG)
  (LET ((ADR (LAM-LOOKUP-NAME REG)))
    (COND ((NULL ADR)
	   (format t "~%symbolic register ~s is undefined. ~s" reg)
	   0)
	  (T (LAM-REGISTER-EXAMINE ADR)))))

(DEFUN LAM-SYMBOLIC-DEPOSIT-REGISTER (REG VAL)
  (LET ((ADR (LAM-LOOKUP-NAME REG)))
    (COND ((NULL ADR)
	   (format t "~%symbolic register ~s is undefined. ~s" reg)
	   0)
	  (T (LAM-REGISTER-DEPOSIT ADR VAL)))))

(DEFUN LAM-SYMBOLIC-REGISTER-IOR (REG VAL)
  (LET ((ADR (LAM-LOOKUP-NAME REG)))
    (COND ((NULL ADR)
	   (format t "~%symbolic register ~s is undefined. ~s" reg)
	   0)
	  (T (LAM-REGISTER-DEPOSIT ADR (LOGIOR VAL (LAM-REGISTER-EXAMINE ADR)))))))

(DEFUN LAM-SYMBOLIC-REGISTER-ANDCAM (REG VAL)
  (LET ((ADR (LAM-LOOKUP-NAME REG)))
    (COND ((NULL ADR)
	   (format t "~%symbolic register ~s is undefined. ~s" reg)
	   0)
	  (T (LAM-REGISTER-DEPOSIT ADR (LOGAND (LOGNOT VAL) (LAM-REGISTER-EXAMINE ADR)))))))

(deff (:property describe-areas lam-colon-cmd) 'lam-describe-areas)
(deff (:property areas lam-colon-cmd) 'lam-describe-areas)

(DEFUN LAM-DESCRIBE-AREAS (IGNORE)
  (TERPRI)
  (LET ((A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
	(A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
	(A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
      ; (A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))

	(R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)))
   (DO ((AREA 0 (1+ AREA))
	(NAREAS 0) (A-NAME))
       ((= AREA (1- (qf-pointer (phys-mem-read (+ 400 %sys-com-number-areas)))))
	(format t "~%Number of active areas = ~S~%"
		NAREAS))
     (SETQ A-NAME (QF-MEM-READ (+ A-N AREA)))
     (COND ((AND (= (LOGLDB %%QF-DATA-TYPE A-NAME) DTP-SYMBOL)
		 (NOT (ZEROP (LOGLDB %%QF-POINTER A-NAME))))
	    (AND (send *terminal-io* :operation-handled-p :read-cursorpos)
		 ( (SEND *terminal-io* :READ-CURSORPOS ':CHARACTER) LAM-FIRST-STATUS-LINE)
		 (PROGN (PRINC '**MORE**) (TYI)
			(SEND *terminal-io* :SET-CURSORPOS 0 0 :CHARACTER)
			(SEND *terminal-io* :CLEAR-REST-OF-LINE)))
	    (SETQ NAREAS (1+ NAREAS))
	    (PRIN1 AREA)		;AREA NUMBER
	    (TYO #\TAB)
	    (LAM-Q-PRINT-TOPLEV A-NAME)  ;AREA-NAME
	    (TYO #\TAB)
	    (PRINC "Region-size ")
	    (princ (QF-MEM-READ (+ A-RS AREA)))
;	    (PRINC " Maximum-size ")
;	    (LAM-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-MS AREA)))
	    (DO ((RN (LOGLDB %%QF-POINTER (QF-MEM-READ (+ A-RL AREA)))
		     (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-LT RN)))))
		((LDB-TEST %%QF-BOXED-SIGN-BIT RN)
		 (COND ((NOT (= AREA (LOGAND RN 777777)))
			(PRINC "Region thread not linked back to AREA!!"))))
	      (LAM-DESCRIBE-REGION RN))
	    (TERPRI))))))

(DEFF (:PROPERTY DESCRIBE-REGION LAM-COLON-CMD) 'LAM-DESCRIBE-REGION)

(DEFUN LAM-DESCRIBE-REGION (RN)
  (LET ((R-O (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
	(R-L (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH))
	(R-B (QF-INITIAL-AREA-ORIGIN 'REGION-BITS))
	(R-FP (QF-INITIAL-AREA-ORIGIN 'REGION-FREE-POINTER))
	(R-GCP (QF-INITIAL-AREA-ORIGIN 'REGION-GC-POINTER))
	(R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)))
    (TERPRI)
    (PRINC "   R ")
    (PRINC RN) 
    (let ((reg-origin (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-O RN))))
	  (reg-length  (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-L RN)))))
      (PRINC ": Origin ")
      (PRINC reg-origin)
      (cond ((not (zerop (logand 37777 reg-origin)))
	     (format t "***")))
      (PRINC " Length ")
      (PRINC reg-length)
      (cond ((not (zerop (logand 37777 reg-origin)))
	     (format t "***"))))
    (PRINC " Free-Ptr ")
    (PRINC (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-FP RN))))
    (PRINC " GC-Ptr ")
    (PRINC (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-GCP RN))))
    (PRINC " ")
    (LET ((BITS (QF-MEM-READ (+ R-B RN))))
      (format t "~% Representation-type: ~s, space-type ~s, Volatility ~s"
	      (NTH (LOGLDB %%REGION-REPRESENTATION-TYPE BITS)
		   '(0 1 lisp unstructured))
	      (NTH (LOGLDB %%REGION-SPACE-TYPE BITS)
		  '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6
			 STATIC FIXED EXTRA-PDL COPY MOBY-FIXED MOBY-NEW 17))
	      (ldb %%region-volatility bits))
      (format t "~% Scavenge enable ~s, Scavenge carefully ~s, Flip enable ~s, Swapin quantum ~s"
	      (ldb %%region-scavenge-enable bits)
	      (ldb %%region-scavenge-carefully bits)
	      (ldb %%region-flip-enable bits)
	      (ldb %%region-swapin-quantum bits)))))

(defun lam-describe-area (area)
  (LET* ((A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
	 (A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
	 (A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
       ; (A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))
	 (a-rb (qf-initial-area-origin 'area-region-bits))
	 (R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD))
	 (A-NAME (QF-MEM-READ (+ A-N AREA))))
     (COND ((AND (= (LOGLDB %%QF-DATA-TYPE A-NAME) DTP-SYMBOL)
		 (NOT (ZEROP (LOGLDB %%QF-POINTER A-NAME))))
	    (AND (send *terminal-io* :operation-handled-p :read-cursorpos)
		 ( (SEND *terminal-io* :READ-CURSORPOS ':CHARACTER) LAM-FIRST-STATUS-LINE)
		 (PROGN (PRINC '**MORE**) (TYI)
			(SEND *terminal-io* :SET-CURSORPOS 0 0 :CHARACTER)
			(SEND *terminal-io* :CLEAR-REST-OF-LINE)))
	    (PRIN1 AREA)		;AREA NUMBER
	    (TYO #\TAB)
	    (LAM-Q-PRINT-TOPLEV A-NAME)  ;AREA-NAME
	    (TYO #\TAB)
	    (PRINC "Region-size ")
	    (LAM-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-RS AREA)))
;	    (PRINC " Maximum-size ")
;	    (LAM-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-MS AREA)))
	    (let ((bits (qf-mem-read (+ a-rb area))))
	      (format t "~% AREA-REGION-BITS: meta ~s, rep ~s, space-type ~s, swap ~s"
		      (ldb %%region-meta-bits bits)
		      (ldb %%region-representation-type bits)
		      (ldb %%region-space-type bits)
		      (ldb %%region-swapin-quantum bits)))
	    (DO ((RN (LOGLDB %%QF-POINTER (QF-MEM-READ (+ A-RL AREA)))
		     (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-LT RN)))))
		((LDB-TEST %%QF-BOXED-SIGN-BIT RN)
		 (COND ((NOT (= AREA (LOGAND RN 777777)))
			(PRINC "Region thread not linked back to AREA!!"))))
	      (LAM-DESCRIBE-REGION RN))
	    (TERPRI)))))


(DEFUN (:PROPERTY ATOM LAM-COLON-CMD) (TEM)
  (SETQ LAM-GETSYL-UNRCH NIL LAM-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
  (SETQ TEM (READ))	;GET NAME OF ATOM USING LISP SYNTAX
  (TERPRI)
  (SETQ TEM (QF-SYMBOL TEM))
  (COND ((< TEM 0)
	 (PRINC "Not found.")
	 (TERPRI))
	(T (LAM-DESCRIBE-THIS-ATOM TEM)))
  (TERPRI)
  NIL)

(DEFUN LAM-DESCRIBE-THIS-ATOM (ADR)
  (PRINT 'LOCATION)
  (PRIN1 (SETQ ADR (QF-POINTER ADR)))
  (PRINT 'VALUE)
  (LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (1+ ADR)))
  (PRINT 'FUNCTION)
  (LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (+ ADR 2)))
  (PRINT 'PLIST)
  (LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (+ ADR 3)))
  (PRINT 'PACKAGE)
  (LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (+ ADR 4)))
  (TERPRI))

(DEFUN (:PROPERTY function LAM-COLON-CMD) (TEM)
  (SETQ LAM-GETSYL-UNRCH NIL LAM-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
  (SETQ TEM (READ))	;GET NAME OF ATOM USING LISP SYNTAX
  (SETQ TEM (QF-SYMBOL TEM))
  (COND ((< TEM 0)
	 (format t "Not found.~&"))
	(T (setq lam-last-value-typed (lam-mem-read (+ tem 2)))
	   (format t "~&")
	   (lam-q-print lam-last-value-typed lam-sexp-prinlevel)
	   (format t " "))))

(DEFUN (:PROPERTY VALUE LAM-COLON-CMD) (TEM)
  (SETQ LAM-GETSYL-UNRCH NIL LAM-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
  (SETQ TEM (READ))	;GET NAME OF ATOM USING LISP SYNTAX
  (SETQ TEM (QF-SYMBOL TEM))
  (COND ((< TEM 0)
	 (format t "Not found.~&"))
	(T (setq lam-last-value-typed (lam-mem-read (+ tem 1)))
	   (format t "~&")
	   (lam-q-print lam-last-value-typed lam-sexp-prinlevel)
	   (format t " "))))

(defun (:property with-output-to-file lam-colon-cmd) (lam-arg)
  (let ((filename (read))
	(command (intern (read) (pkg-find-package 'lam)))
	fstream)
    (if (get command 'lam-colon-cmd)
	(with-open-stream (*standard-output* (make-broadcast-stream
					       (setq fstream
						     (open filename
							   :direction :output
							   :characters t
							   :byte-size 8))
					       *standard-output*))
	  (format fstream "~%;;; Output from LAM program: ~\date\~2%"
		  (time:get-universal-time))
	  (funcall (get command 'lam-colon-cmd) lam-arg))
      (tv:beep)
      (format t "~&No such command: ~A.~%" command))))

(DEFUN (:PROPERTY AREA LAM-COLON-CMD) (ARG)
   (SETQ ARG (OR ARG LAM-LAST-VALUE-TYPED))
   (LET ((AREA-NUM (QF-AREA-NUMBER-OF-POINTER ARG)))
      (PRINC "Area # = ") (PRINC AREA-NUM) (tyo #/space)
      (LAM-Q-PRINT-TOPLEV (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-NAME)
					 AREA-NUM)))
      (TERPRI)
      (lam-describe-area area-num)))

(defun lam-print-area-of-pointer (pntr)
  (let ((area-num (qf-area-number-of-pointer pntr)))
    (format t "Area:[~S]" area-num)
    (lam-q-print-toplev (qf-mem-read (+ (qf-initial-area-origin 'area-name)
					area-num)))))

(DEFUN (:PROPERTY REGION LAM-COLON-CMD) (ARG)
   (SETQ ARG (OR ARG LAM-LAST-VALUE-TYPED))
   (LET ((REGION-NUM (QF-REGION-NUMBER-OF-POINTER-and-check ARG)))
      (FORMAT T "~%REGION # = ~S ~%" REGION-NUM)
      (lam-describe-region region-num)))

(defun (:property check-volatility lam-colon-cmd) (arg)
   (SETQ ARG (OR ARG LAM-LAST-VALUE-TYPED))
   (lam-check-volatility-of-page arg))

(defun lam-check-volatility-of-page (adr)
  (let ((vol (lam-read-volatility adr))
	(handle (lam-read-structure-handle adr))
	(page-base (ash (ash adr -8) 8)))
    (format t "~%Volatily from virtual-page-volatility ~d" vol)
    (lam-scan-for-volatility vol (ldb %%virtual-page-initial-qs handle) page-base)
    (lam-scan-objects vol
		      (- 400 (ldb %%virtual-page-first-header handle))
		      (+ page-base (ldb %%virtual-page-first-header handle)))))

(defun lam-scan-objects (vol nqs localp)
  (prog (header boxed unboxed)
    l  (cond ((<= nqs 0) (return t)))
       (multiple-value (boxed unboxed)
	 (lam-structure-info localp))
  ))

(defvar *boxed-size*)
(defvar *unboxed-size*)
(defvar *structure-info-scan-base*)
(defvar *structure-info-wd*)

(defun lam-structure-info (localp)
;the following code attempts to model the structure-info microcode as much as possible.
  (let* ((*boxed-size* 0)
	 (*unboxed-size* 0)
	 (*structure-info-scan-base* localp)
	 (*structure-info-wd* (qf-mem-read (qf-pointer localp))))
    (select (qf-data-type *structure-info-wd*)
      ()
      ()))
  )

(defun lam-scan-for-volatility (vol nqs localp)
  (dotimes (r nqs)
    (let* ((data (qf-mem-read (+ localp r)))
	   (data-type (qf-data-type data)))
      (if (%pointer-type-p data-type)
	  (let ((pv (lam-volatility-of-pointer (qf-pointer data))))
	    (if (> pv vol)
		(format t "~%Pointer in ~S has volatility ~s"
			(+ localp r) pv))))
      ))
  )

(defun lam-volatility-of-pointer (pntr)
  (let ((region (qf-region-number-of-pointer pntr t)))
    (if region
	(let* ((r-b (qf-initial-area-origin 'region-bits))
	       (bits (qf-mem-read (+ r-b region))))
	  (ldb %%region-volatility bits)))))

(defun (:property maps lam-colon-cmd) (arg)
  (selectq (send *proc* :proc-type)
    (:lambda (lambda-hairy-print-maps arg))
    (:explorer (new-print-maps arg))))

(defun (:property simple-maps lam-colon-cmd) (arg)
  (selectq (send *proc* :proc-type)
    (:lambda (lambda-hairy-print-maps arg t))
    (:explorer (new-simple-print-maps arg))))

(DEFUN lambda-hairy-print-maps (ARG &optional short)
  (SETQ ARG (OR ARG LAM-LAST-VALUE-TYPED))
  (PROG (L1MAPADR L1VAL L2MAPADR L2BITS L2VAL-CONTROL-RAW L2VAL-CONTROL L2VAL-PHYSICAL-PAGE)
	(SETQ L1MAPADR (LDB (if (= %%qf-pointer 0030) 1513 1514) ARG))
	(SETQ L2BITS (LDB 0805 ARG))
	(format t "~O@1// ~O "
		l1mapadr
		(SETQ L1VAL (LOGAND 177 (LAM-REGISTER-EXAMINE (+ RAM1O L1MAPADR)))))
	(format t "~O@2C// ~O "
		(SETQ L2MAPADR (+ (ASH L1VAL 5) L2BITS))
		(SETQ L2VAL-CONTROL-RAW (LAM-REGISTER-EXAMINE (+ RAM2O-CONTROL L2MAPADR))))
	(setq L2VAL-CONTROL (DPB L2VAL-CONTROL-RAW %%PHT2-ACCESS-STATUS-AND-META-BITS 0))
	(SETQ L2VAL-PHYSICAL-PAGE (LAM-REGISTER-EXAMINE (+ RAM2O-PHYSICAL-PAGE L2MAPADR)))
	(FORMAT T " ~O@2P// ~O" L2MAPADR L2VAL-PHYSICAL-PAGE)
	(format t "~&Nubus byte addr = ~O = ~:*~16R"
		(dpb (ldb 0010 arg) 0210 (ash l2val-physical-page 12)))
		;FOLLOWING LINE MOVES BITS TO HIGH PART, WHERE CADR FIELDS ARE DEFINED.
	(lam-print-meta-bits l2val-control-raw)
	(cond ((null short)
	       (if (bit-test 1000 l2val-control-raw)	;access bit
		   (let ((hardware-virtual-address-page
			   (nubus-page-to-hardware-virtual-address-page
			     (ldb 0026 l2val-physical-page))))
		     (cond ((null hardware-virtual-address-page)
			    (format t "~%unable to map to hardware-virtual-address board number"))
			   (t 
			    (format t "~%h-v-a page # ~s, phys-adr(hardware-virtual-adr) ~s"
				    hardware-virtual-address-page
				    (dpb hardware-virtual-address-page 1020 (logand 377 arg)))
			    (let ((quad-slot
				    (logxor (ash (or lam-phys-adr-convert 0) -24.)
					    (ldb 1610 l2val-physical-page))))
			      (format t "~%Memory status of physical memory board ~s~:*(~16r)"
				      quad-slot)
			      (memory-status-quad-slot quad-slot))))))
	       (let ((pht-adr (qf-page-hash-table-lookup arg)))
		 (cond ((< pht-adr 0)
			(format t "~%Not found in PHT")
			(let ((region (qf-region-number-of-pointer
					arg t))
			      )
			  (format t "~% region = ~s" region)
			  (cond ((null region)
				 (format t "~%Not in region"))
				((eq region 'a-mem)
				 (format t "~&A-MEM  ")
				 (LAM-TYPE-OUT (+ (- arg qf-a-memory-virtual-address) raamo)
					       lam-reg-addr-desc T NIL))
				((symbolp region))
				(t
				 (lam-describe-region region)))))
		       (t
			(let ((pht1 (phys-mem-read pht-adr))
			      (pht2 (phys-mem-read (1+ pht-adr))))
			  (format t "~%PHT-ADR=~s PHT1=~s PHT2=~s VOL (true form)= ~s" pht-adr pht1 pht2
				   (ldb %%pht2-volatility pht2))
			  (cond ((null (bit-test 1000 l2val-control-raw))	;access bit
				 (format t "~%No access"))
				(t 
				 (let ((hardware-virtual-address-page
					 (nubus-page-to-hardware-virtual-address-page
					   (ldb 0026 l2val-physical-page)))
				       (region (qf-region-number-of-pointer
						 arg t))
				       (rmb (qf-initial-area-origin 'region-bits)))
				   (COND ((NULL HARDWARE-VIRTUAL-ADDRESS-PAGE)
					  (FORMAT T "~%Map entry cannot be mapped to a hardware virtual address.  It was found in PHT!"))
					 ((NOT (= HARDWARE-VIRTUAL-ADDRESS-PAGE
						  (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2)))
					  (format t "~%Hardware virtual address (~s) does not compare with PHT2 (~s)!!" HARDWARE-VIRTUAL-ADDRESS-PAGE (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2)))
					 ((NOT (= (LDB %%PHT2-META-BITS L2VAL-CONTROL)
						  (LDB %%PHT2-META-BITS PHT2)))
					  (FORMAT T "~%META-BITS in map (~s) differ from those in PHT2 (~s)!!" (LDB %%PHT2-META-BITS L2VAL-CONTROL) (LDB %%PHT2-META-BITS PHT2)))
					 )
				   (format t "~% region = ~s" region)
				   (cond ((null region)
					  (format t "~%Not in region"))
					 ((symbolp region))
					 (t
					  (lam-describe-region region)
					  (cond
					    ((not (= (ldb %%pht2-meta-bits
							  (phys-mem-read (+ region rmb)))
						      (ldb %%pht2-meta-bits pht2)))
					     (format t
						     "~%meta bits in region differ from pht2")
					     )))))))))))
	       (TERPRI)))
	(format t "~%Volatility of contents from virtual-page-volatility ~d"
		(lam-read-volatility (qf-pointer arg)))
	(let ((h (lam-read-structure-handle arg))) 
	  (format t "~%Structure handle of page ~s, initial qs ~s, first header ~s~%"
		(ash (qf-pointer arg) -8)
		(ldb %%virtual-page-initial-qs h)
		(ldb %%virtual-page-first-header h)))
	))

(defun lam-read-volatility (adr)
  (let* ((org (qf-initial-area-origin 'virtual-page-volatility))
	 (page-num (ash adr -8))
	 (word-offset (ash page-num -4))		;2 bits per page
	 (data-shift (* -2 (logand page-num 17))))
    (logand 3 (ash (phys-mem-read (+ org word-offset))
		   data-shift))))

(defun lam-read-structure-handle (adr)
  (let* ((org (qf-initial-area-origin 'virtual-page-data))
	 (page-num (ash (qf-pointer adr) -8)))
    (ldb %%virtual-page-structure-handle (qf-mem-read (+ org page-num)))))

(defun lam-print-meta-bits (l2val-control-raw)
  (let ((L2VAL-CONTROL (DPB L2VAL-CONTROL-RAW %%PHT2-ACCESS-STATUS-AND-META-BITS 0))
	(region-format-bits (dpb l2val-control-raw %%region-map-bits 0)))
    (FORMAT T "~&ACCESS ~S STATUS ~S META ~S "
	    (LDB %%PHT2-MAP-ACCESS-CODE L2VAL-CONTROL)
	    (LDB %%PHT2-MAP-STATUS-CODE L2VAL-CONTROL)
	    (LDB %%PHT2-META-BITS L2VAL-CONTROL)
	   ;(LDB %%PHT2-PHYSICAL-PAGE-NUMBER L2VAL-CONTROL)
	    )
    (FORMAT T "~&META BIT BREAKDOWN: OLDSPACE ~S EXTRA-PDL ~S REGION-REP ~S VOLATILITY-OF-CONTENTS ~S"
	    (LDB %%REGION-OLDSPACE-META-BIT region-format-bits)
	    (LDB %%REGION-EXTRA-PDL-META-BIT region-format-bits)
	    (LDB %%REGION-REPRESENTATION-TYPE region-format-bits)
	    (LDB 1602 region-format-bits))
    (format t "~&STATUS = ~A"
	    (nth (ldb %%pht2-map-status-code l2val-control)
		 '("map not valid" "meta bits only valid" "read only" "read write first"
		   "read write" "may be in pdl buffer" "mar" "???")))
    
    (format t "~&ACCESS = ~A"
	    (nth (ldb %%pht2-map-access-code l2val-control)
		 '("no access" "no access and write permission??"
		   "read only" "read write")))
    (format t "~&META = ")
    (if (ldb-test %%region-oldspace-meta-bit region-format-bits)
	(format t "NEW SPACE (or static or fixed); ")
      (format t "OLD SPACE (or free); "))
    (if (ldb-test %%region-extra-pdl-meta-bit region-format-bits)
	(format t "NOT in EXTRA PDL; ")
      (format t "EXTRA PDL; "))
    (selectq (ldb %%region-representation-type region-format-bits)
      (0 (format t "unused rep 0; "))
      (1 (format t "unused rep 1; "))
      (2 (format t "representation LISP; "))
      (3 (format t "representation UNSTRUCTURED; ")))
    (format t "~&")))

(DEFUN PRINT-L2C-STATUS (L2VAL-CONTROL)
  (FORMAT T "~&ACCESS ~S STATUS ~S META ~S PHYS-PAGE ~S"
	  (LDB %%PHT2-MAP-ACCESS-CODE L2VAL-CONTROL)
	  (LDB %%PHT2-MAP-STATUS-CODE L2VAL-CONTROL)
	  (LDB %%PHT2-META-BITS L2VAL-CONTROL)
	  (LDB %%PHT2-PHYSICAL-PAGE-NUMBER L2VAL-CONTROL))
  (FORMAT T "~&META BIT BREAKDOWN: OLDSPACE ~S EXTRA-PDL ~S REGION-REP ~S UNUSED ~S"
	  (LDB %%REGION-OLDSPACE-META-BIT L2VAL-CONTROL)
	  (LDB %%REGION-EXTRA-PDL-META-BIT L2VAL-CONTROL)
	  (LDB %%REGION-REPRESENTATION-TYPE L2VAL-CONTROL)
	  (LDB 1602 L2VAL-CONTROL))
  (TERPRI))


(defun new-simple-print-maps (vadr)
  (setq vadr (or vadr lam-last-value-typed))
  (let ((l1-adr (ldb (byte 12. 13.) vadr))
	(l2-offset (ldb (byte 5 8) vadr))
	l1-val l2-adr l2-control l2-phys-page nubus-phys
	)
    (setq l1-val (lam-register-examine (+ ram1o l1-adr)))
    (setq l2-adr (ldb (byte 12. 0) (+ (ash l1-val 5) l2-offset)))

    (setq l2-control (lam-register-examine (+ ram2o-control l2-adr)))
    (setq l2-phys-page (lam-register-examine (+ ram2o-physical-page l2-adr)))

    (setq nubus-phys (logand 37777777777
			     (+ (ash l2-phys-page 10.)
				(ash (ldb (byte 8 0) vadr) 2))))

    (format t "~o@1// ~o " l1-adr l1-val)
    (format t "~o@2c// ~o " l2-adr l2-control)
    (format t "~o@2p// ~o " l2-adr l2-phys-page)
    (format t "~&Nubus adr #x~16r" nubus-phys)
    (format t "~&L1 volatility ~o " (ldb (byte 3 7) l1-val))
    (format t "NEW ~o " (ldb (byte 1 10.) l1-val))
    (format t "~&L2 META ~o " (ldb (byte 5 0) l2-control))
    (format t "STATUS ~o ~:*(~[invalid~;meta~;ro~;rwf~;rw~;pdl~;mar~;???~]) "
	    (ldb (byte 3 6) l2-control))
    (format t "WRITE ~o " (ldb (byte 1 8) l2-control))
    (format t "READ ~o " (ldb (byte 1 9) l2-control))
    (format t "FORCED ~o " (ldb (byte 1 10.) l2-control))
    (format t "VOL ~o " (logxor 3 (ldb (byte 2 11.) l2-control)))))
 


;;; STACK PRINTING STUFF

(proclaim '(SPECIAL LAM-STACK-VIRTUAL-ADDRESS-MODE LAM-STACK-M-AP LAM-STACK-PP 
		    LAM-STACK-SVAR-FRAME-EXISTS  LAM-STACK-UPDL-FRAME-EXISTS
		    LAM-STACK-A-QLBNDP LAM-STACK-A-QLPDLO 
		    LAM-STACK-A-QLBNDO LAM-STACK-CURRENT-FRAME-TYPE 
		    LAM-STACK-CURRENT-FRAME-CALL-STATE LAM-STACK-CURRENT-FRAME-EXIT-STATE 
		    LAM-STACK-CURRENT-FRAME-ENTRY-STATE LAM-STACK-CURRENT-FRAME-FCTN 
		    LAM-STACK-PREVIOUS-ACTIVE-FRAME 
		    LAM-STACK-PREVIOUS-OPEN-FRAME LAM-STACK-A-QCSTKG 
		    LAM-STACK-MACRO-PC LAM-STACK-USTACK-DATA))

(proclaim '(SPECIAL %%LP-EXS-EXIT-PC 
		    %%LP-CLS-ADI-PRESENT 
		    %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 
		    %%LP-CLS-DELTA-TO-OPEN-BLOCK 
		    %%LP-EXS-BINDING-BLOCK-PUSHED 
		    %%LP-EXS-MICRO-STACK-SAVED
		    %%LP-ENS-NUM-ARGS-SUPPLIED))

;MODE = NIL -> USE PDL BUFFER ADDRESSES AND ONLY PRINT WHATS IN P.B.
;     = T   -> USE VIRTUAL ADDRESSES  (NOT IMPLEMENTED NOW)
(DEFUN LAM-STACK-SET-VARS-FROM-MACHINE (MODE) 
  (PROG (PDL-BUFFER-HEAD PDL-BUFFER-VIRTUAL-ADDRESS)  
	(SETQ LAM-STACK-VIRTUAL-ADDRESS-MODE MODE)
	(SETQ LAM-STACK-USTACK-DATA (LAM-GET-USTACK-DATA-LIST))
	(SETQ LAM-STACK-M-AP (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
	      LAM-STACK-PP (LAM-SYMBOLIC-EXAMINE-REGISTER 'PP)
	      LAM-STACK-A-QLBNDP (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDP)
	      LAM-STACK-A-QLBNDO (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDO) )
	(COND ((NULL MODE)
		(SETQ LAM-STACK-A-QLPDLO (LAM-SYMBOLIC-EXAMINE-REGISTER 
						'A-PDL-BUFFER-HEAD))
		(SETQ LAM-STACK-M-AP (+ LAM-STACK-M-AP RAPBO))
		(SETQ LAM-STACK-PP (+ LAM-STACK-PP RAPBO))
		(SETQ LAM-STACK-A-QLPDLO (+ LAM-STACK-A-QLPDLO RAPBO)))
	      (T (SETQ LAM-STACK-A-QLPDLO (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-QLPDLO))
		 (SETQ PDL-BUFFER-HEAD (LOGLDB %%QF-POINTER 
			(LAM-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-HEAD)))
		 (SETQ PDL-BUFFER-VIRTUAL-ADDRESS (LOGLDB %%QF-POINTER 
			(LAM-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS)))
		 (SETQ LAM-STACK-M-AP (+ PDL-BUFFER-VIRTUAL-ADDRESS 
			(LOGAND 3777 (- LAM-STACK-M-AP PDL-BUFFER-HEAD))))
		 (SETQ LAM-STACK-PP (+ PDL-BUFFER-VIRTUAL-ADDRESS 
			(LOGAND 3777 (- LAM-STACK-PP PDL-BUFFER-HEAD))))
		))   ;RELOCATE AP, ETC TO VIRTUAL ADDRESSES
	(LAM-STACK-CURRENT-FRAME-SETUP MODE)
	(SETQ LAM-STACK-SVAR-FRAME-EXISTS NIL)
	(COND ((EQ LAM-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
		(SETQ LAM-STACK-SVAR-FRAME-EXISTS
			 (NOT (ZEROP (LOGLDB %%M-FLAGS-QBBFL 
					     (LAM-SYMBOLIC-EXAMINE-REGISTER 
							'M-FLAGS)))))))
	(SETQ LAM-STACK-UPDL-FRAME-EXISTS NIL)
	(SETQ LAM-STACK-MACRO-PC (current-lc-in-halfwords))
))



(DEFUN LAM-STACK-XFER-USTACK (&OPTIONAL PRINT-FLAG)
  (PROG (DATA LST)
   L	(COND ((NOT (> LAM-STACK-A-QLBNDP LAM-STACK-A-QLBNDO))
	       (format t "~%~%Bind stack exhausted during ustack xfer~%")
	       (RETURN lst)))
	(SETQ LST (CONS (SETQ DATA (QF-MEM-READ LAM-STACK-A-QLBNDP))
			LST))
	(SETQ LAM-STACK-A-QLBNDP (1- LAM-STACK-A-QLBNDP))
	(COND ((= 0 (LDB %%SPECPDL-BLOCK-START-FLAG DATA))
	       (GO L)))
	(COND (PRINT-FLAG
	       (FORMAT T "~%--XFERRED USTACK--")
	       (DOLIST (E LST)
		 (FORMAT T "~%    ")
		 (COND ((= DTP-FIX (QF-DATA-TYPE E))
			(PRIN1 (LAM-FIND-CLOSEST-SYM (+ (QF-POINTER E) RACMO))))
		       (T (FORMAT T "Data type not fix!! word is #<")
			  (lam-type-out e lam-q-desc nil nil)
			  (format t ">~&"))))))
	(RETURN LST)
))

;SET UP VARS TO FRAME LAM-STACK-M-AP POINTS
(DEFUN LAM-STACK-CURRENT-FRAME-SETUP (MODE) 
  (PROG (TEM) 
    (COND ((NULL MODE) 
	(SETQ LAM-STACK-CURRENT-FRAME-CALL-STATE 
		(LAM-REGISTER-EXAMINE (- LAM-STACK-M-AP 3)))
	(SETQ LAM-STACK-CURRENT-FRAME-EXIT-STATE 
		(LAM-REGISTER-EXAMINE (- LAM-STACK-M-AP 2)))
	(SETQ LAM-STACK-CURRENT-FRAME-ENTRY-STATE 
		(LAM-REGISTER-EXAMINE (- LAM-STACK-M-AP 1)))
	(SETQ LAM-STACK-CURRENT-FRAME-FCTN (LAM-REGISTER-EXAMINE LAM-STACK-M-AP)) )
    (T 	(SETQ LAM-STACK-CURRENT-FRAME-CALL-STATE 
		(LAM-MEM-READ (- LAM-STACK-M-AP 3)))
	(SETQ LAM-STACK-CURRENT-FRAME-EXIT-STATE 
		(LAM-MEM-READ (- LAM-STACK-M-AP 2)))
	(SETQ LAM-STACK-CURRENT-FRAME-ENTRY-STATE 
		(LAM-MEM-READ (- LAM-STACK-M-AP 1)))
	(SETQ LAM-STACK-CURRENT-FRAME-FCTN (LAM-MEM-READ LAM-STACK-M-AP)) ))

	(SETQ LAM-STACK-CURRENT-FRAME-TYPE (NTH (LDB %%QF-DATA-TYPE 
						       LAM-STACK-CURRENT-FRAME-FCTN)
						Q-DATA-TYPES))
	(SETQ TEM (LDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 
			  LAM-STACK-CURRENT-FRAME-CALL-STATE))
	(SETQ LAM-STACK-PREVIOUS-ACTIVE-FRAME 
		(COND ((= TEM 0) NIL)
		      (T (- LAM-STACK-M-AP TEM)) ))
	(SETQ TEM (LDB %%LP-CLS-DELTA-TO-OPEN-BLOCK 
			  LAM-STACK-CURRENT-FRAME-CALL-STATE))
	(SETQ LAM-STACK-PREVIOUS-OPEN-FRAME 
		(- LAM-STACK-M-AP TEM))
	(SETQ LAM-STACK-MACRO-PC
	      (COND ((EQ LAM-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
		     (LDB %%LP-EXS-EXIT-PC 
			  LAM-STACK-CURRENT-FRAME-EXIT-STATE))
		    (T -1)))
))


(DEFUN LAM-STACK-SPACE-BIND-STACK (&OPTIONAL PRINT-FLAG)
 (PROG ()
	(COND ((EQ LAM-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
	       (COND (LAM-STACK-UPDL-FRAME-EXISTS
		      (SETQ LAM-STACK-USTACK-DATA (LAM-STACK-XFER-USTACK PRINT-FLAG)))
		     (T (SETQ LAM-STACK-USTACK-DATA NIL)))
	       (COND (LAM-STACK-SVAR-FRAME-EXISTS 
		      (LAM-STACK-SPACE-BINDING-BLOCK PRINT-FLAG))))
	      ((EQ LAM-STACK-CURRENT-FRAME-TYPE 'DTP-U-ENTRY)
	       (GO L1)))
   X	(RETURN T)
   L1
 ;	(SETQ TEM LAM-STACK-USTACK-DATA)		;**********
 ; L2	(COND ((NULL TEM) (GO X))
 ;	      ((NOT (ZEROP (LOGAND (CAR LAM-STACK-USTACK-DATA) 1_19.))) ;PPBSPC
 ;	       (LAM-STACK-SPACE-BINDING-BLOCK PRINT-FLAG)))
 ;	(SETQ TEM (CDR TEM))
 ;	(GO L2)
   ))

(DEFUN LAM-STACK-SPACE-BINDING-BLOCK (&OPTIONAL PRINT-FLAG) 
  (PROG (BOUND-LOC-POINTER PREV-CONTENTS)
   L	(COND ((NOT (> LAM-STACK-A-QLBNDP LAM-STACK-A-QLBNDO))
	       (RETURN T)))
	(SETQ BOUND-LOC-POINTER (QF-MEM-READ LAM-STACK-A-QLBNDP))
	(COND ((NOT (= DTP-LOCATIVE (LDB %%QF-DATA-TYPE BOUND-LOC-POINTER)))
	       (cond ((null print-flag)
		      (format t "~%Turning on printout of special stack frames!!")
		      (setq print-flag t)))
	       (format t "~%Paired pointer on special stack not locative.")))
	(SETQ PREV-CONTENTS (QF-MEM-READ (1- LAM-STACK-A-QLBNDP)))
	(COND (PRINT-FLAG
	       (LET ((ANUM (QF-AREA-NUMBER-OF-POINTER BOUND-LOC-POINTER)))
		 (cond ((symbolp anum)
			(format t "~&  Bound locn(~s): ~s  (~s)" lam-stack-a-qlbndp
				bound-loc-pointer anum)
			(if (eq anum 'a-mem)
			    (lam-print-address (+ raamo (- (qf-pointer bound-loc-pointer)
							   (si:%pointer-unsigned A-MEMORY-VIRTUAL-ADDRESS)))))
			)
		       (t (let* ((ANAME (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-NAME)
							ANUM)))
				 (ANUM-OF-ANAME (QF-AREA-NUMBER-OF-POINTER ANAME)))
			    (COND ((= ANUM ANUM-OF-ANAME)		;P-N-STRING
				   (FORMAT T "~&  BOUND-SYMBOL(~s): "
					   lam-stack-a-qlbndp)
				   (LAM-PRINT-SYMBOL-FROM-POINTER-WITHIN-VECTOR
				     (1- BOUND-LOC-POINTER)))
				  (T
				   (FORMAT T "~&  LOCATIVE slot: ")
				   (LAM-Q-PRINT-TOPLEV BOUND-LOC-POINTER)))))))
	       (FORMAT T "  SAVED CONTENTS:  ")
	       (LAM-Q-PRINT-TOPLEV PREV-CONTENTS)
	       (TERPRI)))
	(SETQ LAM-STACK-A-QLBNDP (- LAM-STACK-A-QLBNDP 2))
	(COND ((= 0 (LDB %%SPECPDL-BLOCK-START-FLAG PREV-CONTENTS))  ;sense??
	       (GO L)))
	(RETURN T)
))

(DEFUN LAM-PRINT-SYMBOL-FROM-POINTER-WITHIN-VECTOR (POINTER)
  (DO ((COUNT 0 (1+ COUNT))
       (PTR POINTER (1- PTR)))
      ((> COUNT 4)
       (FORMAT T " UNABLE TO FIND SYMBOL HEADER ~S" POINTER))
    (LET ((Q (QF-MEM-READ PTR)))
      (COND ((= (LDB %%QF-DATA-TYPE Q) DTP-SYMBOL-HEADER)
	     (LAM-Q-PRINT-TOPLEV (QF-MAKE-Q PTR DTP-SYMBOL))
	     (RETURN T))))))

(DEFUN (:PROPERTY STKP LAM-COLON-CMD) (CNT) (LAM-PRINT-PDL-1 CNT T))

(DEFF (:PROPERTY BAKTRACE LAM-COLON-CMD) 'LAM-BAKTRACE)
(DEFF (:PROPERTY BACKTRACE LAM-COLON-CMD) 'LAM-BAKTRACE)

(DEFUN LAM-BAKTRACE (CNT) (LAM-PRINT-PDL-1 CNT NIL))

(DEFUN (:PROPERTY STKP-WITH-BINDS LAM-COLON-CMD) (CNT)
  (LAM-PRINT-PDL-1 CNT T T))

;ARG IS NUMBER OF BLOCKS TO PRINT
(DEFUN LAM-PRINT-PDL-1 (CNT PRINT-ARGS-FLAG &OPTIONAL PRINT-BIND-STACK)
 (PROG (MODE)
       (QF-INITIALIZE-FOR-LISP-REFERENCE)
       (SETQ MODE T)
       (TERPRI)
       (COND ((NULL CNT) (SETQ CNT 100005))
	     ((< CNT 0) (SETQ CNT (- 0 CNT)) (SETQ MODE NIL))) ;NEG NUMBER OF BLOCKS DOESNT
			;GO THRU PAGING HAIR, ETC.
       (LAM-STACK-SET-VARS-FROM-MACHINE MODE)
    L  (LAM-STACK-PRINT-STACK-FRAME MODE PRINT-ARGS-FLAG)
       (COND ((< (SETQ CNT (1- CNT)) 0) (RETURN T))
	     ((KBD-TYI-NO-HANG)
	      (RETURN 'LISTEN)))
;INDEX BACK TO PREVIOUS STACK FRAME
    L0 (COND ((NULL LAM-STACK-PREVIOUS-ACTIVE-FRAME) (RETURN T)))
       (LAM-STACK-SPACE-BIND-STACK PRINT-BIND-STACK)
       (SETQ LAM-STACK-M-AP LAM-STACK-PREVIOUS-ACTIVE-FRAME)
       (LAM-STACK-CURRENT-FRAME-SETUP MODE)
       (SETQ LAM-STACK-UPDL-FRAME-EXISTS
	     (ldb-test %%LP-EXS-MICRO-STACK-SAVED LAM-STACK-CURRENT-FRAME-EXIT-STATE))
       (SETQ LAM-STACK-SVAR-FRAME-EXISTS
	     (ldb-test %%LP-EXS-BINDING-BLOCK-PUSHED LAM-STACK-CURRENT-FRAME-EXIT-STATE))
       (GO L)
))

;mode nil -> register address mode, t -> virtual memory mode.
(DEFUN LAM-STACK-PRINT-STACK-FRAME (MODE PRINT-ARGS-FLAG) 
  (PROG (ADR CNT) ;TEM ADL-POINTER ARG-DESC VAR-NAME SV-LIST-POINTER
	(DECLARE (FIXNUM ADR CNT)) ;TEM ADL-POINTER ARG-DESC SV-LIST-POINTER
	(PRIN1-THEN-SPACE LAM-STACK-M-AP)
	(LAM-Q-PRINT-TOPLEV LAM-STACK-CURRENT-FRAME-FCTN)
	(format t "[~S]" (LDB %%LP-EXS-EXIT-PC LAM-STACK-CURRENT-FRAME-EXIT-STATE))
	(cond ((and (boundp '%%lp-cls-attention)
		    (ldb-test %%lp-cls-attention lam-stack-current-frame-call-state))
	       (format t "{ATT}")))
	(cond ((ldb-test %%lp-cls-self-map-provided lam-stack-current-frame-call-state)
	       (format t "{SM}")))
	(cond ((ldb-test %%lp-cls-adi-present lam-stack-current-frame-call-state)
	       (format t "{ADI}")))
	(cond ((ldb-test %%lp-exs-binding-block-pushed lam-stack-current-frame-exit-state)
	       (format t "{Binding Block}")))
	(cond ((ldb-test %%lp-exs-micro-stack-saved lam-stack-current-frame-exit-state)
	       (format t "{saved micro-stack: ")
	       (DOLIST (E LAM-STACK-USTACK-DATA)
		 (LAM-PRINT-ADDRESS (+ RACMO (LOGAND 177777 E)))
		 (FORMAT T " "))
	       (format t "}")
	       ))
	(COND ((NULL PRINT-ARGS-FLAG) (TERPRI) (RETURN T)))
	(SETQ ADR (1+ LAM-STACK-M-AP))
	(SETQ CNT (LDB %%LP-ENS-NUM-ARGS-SUPPLIED 
			  LAM-STACK-CURRENT-FRAME-ENTRY-STATE))
;	(COND ((AND (EQ LAM-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
;		    (NOT (= 0 (LDB %%FEFH-SV-BIND 
;				     (QF-MEM-READ (LDB %%QF-POINTER 
;							  LAM-STACK-CURRENT-FRAME-FCTN))))))
;		(SETQ ADL-POINTER (LOGLDB %%QF-POINTER 
;		   (+ LAM-STACK-CURRENT-FRAME-FCTN (LOGLDB %%FEFHI-MS-ARG-DESC-ORG 
;		      (QF-MEM-READ (LOGLDB %%QF-POINTER 
;			(+ LAM-STACK-CURRENT-FRAME-FCTN %FEFHI-MISC)))))))
;		(SETQ SV-LIST-POINTER (LOGLDB %%QF-POINTER 
;		   (+ LAM-STACK-CURRENT-FRAME-FCTN %FEFHI-SPECIAL-VALUE-CELL-PNTRS)))))
    L	(COND ((= CNT 0) (TERPRI) (RETURN T)))
	(tyo #/space)
;	(COND (ADL-POINTER 
;		(SETQ ARG-DESC (QF-MEM-READ ADL-POINTER))
;		(SETQ VAR-NAME NIL)
;		(SETQ ADL-POINTER 
;		  (+ ADL-POINTER 
;		     1 
;		     (COND ((= 0 (LOGLDB %%FEF-NAME-PRESENT ARG-DESC)) 0) 
;			    (T (SETQ VAR-NAME (QF-MEM-READ (+ ADL-POINTER 1))) 1))
;		     (COND ((OR (= (SETQ TEM (LOGLDB %%FEF-INIT-OPTION ARG-DESC))
;				   FEF-INI-PNTR)
;				(= TEM FEF-INI-C-PNTR)
;				(= TEM FEF-INI-OPT-SA)
;				(= TEM FEF-INI-EFF-ADR))
;			      1)
;			    (T 0)))) ))
	(LAM-Q-PRINT-TOPLEV (COND ((NULL MODE) (LAM-REGISTER-EXAMINE ADR))
				 (T (LAM-MEM-READ ADR))))
	(SETQ CNT (1- CNT) ADR (1+ ADR))
	(GO L)
 ))


(DEFUN LAM-GET-USTACK-DATA-LIST NIL   ;RETURNS A LIST OF CONTENTS OF USTACK
   (PROG (USP DATA)		     ; CAR OF RESULT WOULD BE POPJ ED TO FIRST
	(SETQ USP (LAM-SYMBOLIC-EXAMINE-REGISTER 'USP))
	(COND ((= USP 377) (RETURN NIL)))
    L	(COND ((NOT (> USP 0)) (RETURN (NREVERSE DATA))))
	(SETQ DATA (CONS (LAM-REGISTER-EXAMINE (+ USP RAUSO))
			 DATA))
	(SETQ USP (1- USP))
	(GO L)))


;;; BREAKPOINTS	

(DEFUN (:PROPERTY LISTB LAM-COLON-CMD) (QUAN)
  QUAN
  (AND LAM-BREAKPOINT-LIST (PRINT 'PERMANENT-BREAKPOINTS))
  (DO X LAM-BREAKPOINT-LIST (CDR X) (NULL X)
    (TERPRI) (LAM-PRINT-ADDRESS (CAR X)))
  (AND LAM-TEMPORARY-BREAKPOINT-LIST (PRINT 'TEMPORARY-BREAKPOINTS))
  (DO X LAM-TEMPORARY-BREAKPOINT-LIST (CDR X) (NULL X)
    (TERPRI) (LAM-PRINT-ADDRESS (CDR X)))
  (AND (NULL LAM-BREAKPOINT-LIST) (NULL LAM-TEMPORARY-BREAKPOINT-LIST)
       (PRINT 'NONE))
  (LAM-CR NIL))

(DEFUN (:PROPERTY B LAM-COLON-CMD) (QUAN)
  (LAM-SET-BREAKPOINT (OR QUAN LAM-LAST-OPEN-REGISTER) T)
  (LAM-CR NIL))

(DEFUN (:PROPERTY TB LAM-COLON-CMD) (QUAN)
  (LAM-SET-BREAKPOINT (OR QUAN LAM-LAST-OPEN-REGISTER) NIL)
  (LAM-CR NIL))

(DEFUN (:PROPERTY TBP LAM-COLON-CMD) (QUAN)
  (LAM-SET-BREAKPOINT (OR QUAN LAM-LAST-OPEN-REGISTER) NIL)
  (LAM-CONTIN NIL))

(DEFUN (:PROPERTY G LAM-COLON-CMD) (QUAN)
  (LAM-GO 1)		;WARM BOOT, THEN CONTINUE N TIMES.
  (LAM-CONTIN QUAN))

(DEFF (:PROPERTY P LAM-COLON-CMD) 'LAM-CONTIN)

(DEFUN LAM-CONTIN (QUAN)
  QUAN
  (LAM-PROCEED NIL)
  (COND ((NOT (NULL LAM-TEMPORARY-BREAKPOINT-LIST))
	 (MAPC 'LAM-UNSET-BREAKPOINT LAM-TEMPORARY-BREAKPOINT-LIST)
	 (PRINT '(TEMPORARY-BREAKPOINTS-REMOVED))))
  (LAM-CR NIL))

(DEFF (:PROPERTY UB LAM-COLON-CMD) 'LAM-UNSET-BKPT)

(DEFUN LAM-UNSET-BKPT (LOC)
  (OR LOC (SETQ LOC LAM-LAST-OPEN-REGISTER))
  (COND ((NULL LOC)
	 (SETQ LOC (+ -1 RACMO LAM-SAVED-PC))))
  (COND ((OR (MEMBER LOC LAM-BREAKPOINT-LIST)
	     (MEMBER LOC LAM-TEMPORARY-BREAKPOINT-LIST))
	   (LAM-UNSET-BREAKPOINT (OR LOC LAM-LAST-OPEN-REGISTER)))
	(T (PRINT 'NO-BREAKPOINT-AT)
	   (LAM-PRINT-ADDRESS LOC)))
  (LAM-CR NIL))

(DEFF (:PROPERTY UAB LAM-COLON-CMD) 'LAM-UNSET-ALL-BKPTS)
  
(DEFUN LAM-UNSET-ALL-BKPTS (QUAN)
  QUAN
  (MAPC 'LAM-UNSET-BREAKPOINT LAM-BREAKPOINT-LIST)
  (MAPC 'LAM-UNSET-BREAKPOINT LAM-TEMPORARY-BREAKPOINT-LIST)
  (LAM-CR NIL))

(DEFUN (:PROPERTY RB LAM-COLON-CMD) (IGNORE)
  (MAPC 'LAM-STORE-BREAKPOINT LAM-BREAKPOINT-LIST)
  (MAPC 'LAM-STORE-BREAKPOINT LAM-TEMPORARY-BREAKPOINT-LIST)
  (LAM-CR NIL))

(DEFUN (:PROPERTY RETURN-BREAK LAM-COLON-CMD) (IGNORE)
  (LET ((PC (LAM-REGISTER-EXAMINE RAPC))
	(IR (LAM-REGISTER-EXAMINE RASIR)))
    (COND ((OR (NOT (= (LDB com-IR-OP IR) com-OP-JUMP))
	       (NOT (= 1 (LDB com-IR-P IR))))
	   (FORMAT T "~%IR IS NOT A PUSHJ"))
	  (T (LAM-SET-BREAKPOINT (+ RACMO (+ PC		;PC IS ALREADY +1
					     (COND ((= (LDB com-IR-N IR) 0) 1)
						   (T 0))))
				 T)
	     (FORMAT T "~%OK")))))

(DEFUN (:PROPERTY US-BREAK LAM-COLON-CMD) (IGNORE)
  (LET* ((USP (LAM-REGISTER-EXAMINE RAUSP))
		(TOP-RETURN (LAM-REGISTER-EXAMINE (+ USP RAUSO))))
	   (LAM-SET-BREAKPOINT (+ RACMO TOP-RETURN) T)
	   (FORMAT T "BREAKPOINT SET AT ~S~%" (LAM-FIND-CLOSEST-SYM (+ RACMO TOP-RETURN)))))

;(COMMENT
;	(LAM-LAST-VALUE-TYPED
;	 (LAM-SET-BREAKPOINT (+ RACMO LAM-LAST-VALUE-TYPED) T)
;	 (FORMAT T "~%OK~%")))

(DEFUN LAM-SET-BREAKPOINT (LOC PERMANENT)
  (COND ((NOT (EQ 'C (LAM-FIND-REG-ADR-RANGE LOC)))
	 (PRINT 'BKPT-NOT-IN-C-MEM))
	(T
	 (lam-store-breakpoint loc)
	 (COND (PERMANENT
		(SETQ LAM-BREAKPOINT-LIST (CONS LOC LAM-BREAKPOINT-LIST)))
	       ((SETQ LAM-TEMPORARY-BREAKPOINT-LIST
		      (CONS LOC LAM-TEMPORARY-BREAKPOINT-LIST))))))
   )

(defun lam-store-breakpoint (loc)
  (let ((contents (LAM-REGISTER-EXAMINE LOC)))
    (IF (= (LDB com-IR-HALT CONTENTS) 1)
	(FORMAT T "~%WARNING, HALT BIT ALREADY SET"))
    (LAM-REGISTER-DEPOSIT LOC (DPB 1 com-IR-HALT CONTENTS))))

(DEFUN LAM-UNSET-BREAKPOINT (LOC)
  (PROG (CONTENTS HALT)
    (OR (EQ 'C (LAM-FIND-REG-ADR-RANGE LOC))
	(RETURN (PRINT 'BKPT-NOT-IN-C-MEM)))
    (SETQ CONTENTS (LAM-REGISTER-EXAMINE LOC))
    (SETQ HALT (LDB com-IR-HALT CONTENTS))
    (COND ((NOT (= HALT 1))
	   (FORMAT T "~%BREAKPOINT-CLOBBERED ")
	   (LAM-PRINT-ADDRESS LOC))
	  (T (LAM-REGISTER-DEPOSIT LOC (DPB 0 com-IR-HALT CONTENTS))))
    (SETQ LAM-BREAKPOINT-LIST (DELETE LOC LAM-BREAKPOINT-LIST))
    (SETQ LAM-TEMPORARY-BREAKPOINT-LIST (DELETE LOC LAM-TEMPORARY-BREAKPOINT-LIST))
   ))


(ARRAY LAM-LEVEL-1-MAP-FREQUENCIES FIXNUM 128.)
(ARRAY LAM-LEVEL-1-REVERSE-MAP FIXNUM 128.)

(DEFUN (:PROPERTY CHECK-MAP LAM-COLON-CMD) (TEM)
 (PROG (NUM-CHECKED-OK L1-MAP MASKED-L1-MAP PRINT-MAP-FREQS)
  (SETQ NUM-CHECKED-OK 0)
  (DO I 0 (1+ I) (= I 128.)
      (STORE (LAM-LEVEL-1-MAP-FREQUENCIES I) 0))
  (DO ((ADR RAM1O (1+ ADR))
       (END-ADR (+ RAM1O (if (= %%qf-pointer 30) 4000 10000))))
      ((= ADR END-ADR))
    (SETQ MASKED-L1-MAP (LOGAND 177 (SETQ L1-MAP (LAM-REGISTER-EXAMINE ADR))))
    (STORE (LAM-LEVEL-1-MAP-FREQUENCIES MASKED-L1-MAP)
	   (SETQ TEM (1+ (LAM-LEVEL-1-MAP-FREQUENCIES MASKED-L1-MAP))))
    (COND ((AND (NOT (= MASKED-L1-MAP 177))	 ;NO LEVEL 1 MAP ENTRYS SHOULD BE DUPLICATED
		(NOT (= TEM 1)))	 ; EXCEPT 177
	   (FORMAT T "~%TRIGGERED ON L1-MAP ~O, FREQ ~O" L1-MAP TEM)
	   (SETQ PRINT-MAP-FREQS T)))
    (STORE (LAM-LEVEL-1-REVERSE-MAP MASKED-L1-MAP)
	   (- ADR RAM1O)))
  (COND (PRINT-MAP-FREQS
	 (DO ((I 0 (1+ I)))
	     ((= I 128.))
	   (FORMAT T "~%LEVEL-1-MAP-VALUE ~S APPEARS ~S" I (LAM-LEVEL-1-MAP-FREQUENCIES I)))))
  (DO ((I 0 (1+ I))
       (NOT-177S 0))
      ((= I 127.)
       (FORMAT T "~%NOT-177S ~s" NOT-177S))
    (SETQ TEM (LAM-LEVEL-1-MAP-FREQUENCIES I))
    (SETQ NOT-177S (+ NOT-177S TEM))
    (COND ((ZEROP TEM)
	   (FORMAT T "~%LEVEL-2-MAP-BLOCK ~S NOT-USED" I)
	   (GO E))
	  ((> TEM 1)
	   (FORMAT T "~%LEVEL-2-MAP-BLOCK ~S USED ~S TIMES" I TEM)))
    (SETQ NUM-CHECKED-OK 
	  (+ (LAM-CHECK-LEVEL-2-BLOCK (ASH (LAM-LEVEL-1-REVERSE-MAP I) 13.)
				      I)
	     NUM-CHECKED-OK))
    E)
  (FORMAT T "~%MAP-ENTRIES-CHECKED-OK ~S" NUM-CHECKED-OK)
  (RETURN NIL)))

;arg, if present, is l2 map block number to begin at.
(defun (:property check-l2-map lam-colon-cmd) (arg)
  (do ((i (if (null arg) 0 arg) (1+ i))
       (num-checked-ok 0))
      ((= i 127.)
       (FORMAT T "~%MAP-ENTRIES-CHECKED-OK ~S" NUM-CHECKED-OK))
    (setq num-checked-ok (+ num-checked-ok
			    (lam-check-level-2-block (lam-register-examine (+ 2000 i raamo))
						     i)))))

(proclaim '(SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE))

(proclaim '(SPECIAL A-MEMORY-VIRTUAL-BASE-ADDRESS))

(SETQ A-MEMORY-VIRTUAL-BASE-ADDRESS (DPB (LSH A-MEMORY-VIRTUAL-ADDRESS -27)
					 2701
					 (DPB A-MEMORY-VIRTUAL-ADDRESS 0027 0)))

(DEFUN LAM-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
 (PROG (L2M-CONTROL L2M-PHYSICAL-ADDRESS L2M-CONTROL-SHIFTED
	PHT-ADR VIR-ADR NUM-CHECKED-OK L2MAP-SA-CONTROL
	L2MAP-SA-PHYSICAL-ADDRESS)
   (SETQ NUM-CHECKED-OK 0)
   (SETQ L2MAP-SA-CONTROL (+ RAM2O-CONTROL (LSH LEVEL-2-BLOCK-NUMBER 5))
	 L2MAP-SA-PHYSICAL-ADDRESS (+ RAM2O-PHYSICAL-PAGE (LSH LEVEL-2-BLOCK-NUMBER 5)))
   (DO ADR-IN-BLOCK 0 (1+ ADR-IN-BLOCK) (= ADR-IN-BLOCK 32.)
       (SETQ L2M-CONTROL (LAM-REGISTER-EXAMINE (+ ADR-IN-BLOCK L2MAP-SA-CONTROL)))
       (SETQ L2M-PHYSICAL-ADDRESS
	     (LAM-REGISTER-EXAMINE (+ ADR-IN-BLOCK L2MAP-SA-PHYSICAL-ADDRESS)))
       (SETQ L2M-CONTROL-SHIFTED (ASH L2M-CONTROL 16))  ;shift into position so CADR %% byte
		;definitions will work.
       (COND ((>= (LDB %%PHT2-MAP-STATUS-CODE L2M-CONTROL-SHIFTED)  ;IF LEVEL 2 MAP SET UP ...
		  %PHT-MAP-STATUS-READ-ONLY)
	      (SETQ PHT-ADR (QF-PAGE-HASH-TABLE-LOOKUP
			     (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
	      (COND ((< PHT-ADR 0)
		     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS)
			    (FORMAT T "~%Map entry at virtual address ~s not found in pht"
				    VIR-ADR)
			    (FORMAT T "~% map-value ~s level-2-map-adr ~s"
				    L2M-CONTROL-SHIFTED
				    (+ (LSH LEVEL-2-BLOCK-NUMBER
					    5)
				       ADR-IN-BLOCK)))))
		    (T
		     (LET* ((PHT1-VALUE (PHYS-MEM-READ PHT-ADR))
			    (PHT2-VALUE (PHYS-MEM-READ (1+ PHT-ADR)))
			    (NUBUS-PAGE (LDB 0026 L2M-PHYSICAL-ADDRESS))
			    (HARDWARE-VIRTUAL-ADDRESS-PAGE
			      (NUBUS-PAGE-TO-HARDWARE-VIRTUAL-ADDRESS-PAGE NUBUS-PAGE)))
		       (COND ((NULL HARDWARE-VIRTUAL-ADDRESS-PAGE)
			      (FORMAT T "~%Map entry at virtual address ~s cannot be mapped to a hardware virtual address.  It was found in PHT!"
				      VIR-ADR)
			      (FORMAT T "~% L2M control ~s, L2M phys-page ~s, pht1 ~s, pht2 ~s"
				      L2M-CONTROL
				      L2M-PHYSICAL-ADDRESS
				      PHT1-VALUE
				      PHT2-VALUE))
			     ((NOT (= HARDWARE-VIRTUAL-ADDRESS-PAGE
				      (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2-VALUE)))
			      (format t "~%Map entry at virtual address ~S maps into hardware virtual address which does not compare with PHT2"
				      vir-adr)
			      (format t "~%  Hardware-virtual-page-number of map ~s, pht2 ~s"
				      HARDWARE-VIRTUAL-ADDRESS-PAGE
				      PHT2-VALUE)
			      (FORMAT T "~%  PHT1 ~s, PHT-ADDR ~s, L2M-CONTROL-SHIFTED ~s, L2 map adr ~s"
				      PHT1-VALUE
				      PHT-ADR 
				      L2M-CONTROL-SHIFTED
				      (+ (LSH LEVEL-2-BLOCK-NUMBER
					      5)
					 ADR-IN-BLOCK)))
			     ((NOT (= (LDB %%PHT2-META-BITS L2M-CONTROL-SHIFTED)
				      (LDB %%PHT2-META-BITS PHT2-VALUE)))
			      (FORMAT T "~%MAP-ENTRY-AT-VIRTUAL-ADDRESS ~s META-BITS-DIFFER"
				      VIR-ADR)
			      (format t "~%Map value ~s, PHT2 ~s, pht adr ~S, level-2-map adr ~s"
				      L2M-CONTROL-SHIFTED
				      PHT2-VALUE 
				      PHT-ADR 
				      (+ (LSH LEVEL-2-BLOCK-NUMBER
					      5)
					 ADR-IN-BLOCK)))
			     (T (SETQ NUM-CHECKED-OK (1+ NUM-CHECKED-OK))))))))))
   (RETURN NUM-CHECKED-OK)))

;I don't know if this prints anything sensible at all...
(defun (:property print-pht lam-colon-cmd) (start)
  (do ((pht-entry (or start 0) (1+ pht-entry)))
      ((>= pht-entry (// (ash (cadr (memq 'page-table-area cold-load-area-sizes)) 8) 2)))
    (let* ((pht1 (phys-mem-read (+ pht-addr (* 2 pht-entry))))
	   (pht2 (phys-mem-read (+ pht-addr 1 (* 2 pht-entry))))
	   (real-phys-adr (ignore-errors (cadr-page-to-nubus-page (ash (ldb 0026 pht1) -8))))
	   )
    (format t "~&~7o: ~o ~o ~16r" pht-entry pht1 pht2
	    (and real-phys-adr (ash real-phys-adr 10.))))))


(DEFUN (:PROPERTY check-map-bulk lam-colon-cmd) (TEM)
 (PROG (NUM-CHECKED-OK L1-MAP MASKED-L1-MAP PRINT-MAP-FREQS)
  (SETQ NUM-CHECKED-OK 0)
  (DO I 0 (1+ I) (= I 128.)
      (STORE (LAM-LEVEL-1-MAP-FREQUENCIES I) 0))
  (DO ((ADR 0 (1+ ADR))
       (END-ADR 4000))	;** 24 bit address mode**
      ((= ADR END-ADR))
    (SETQ MASKED-L1-MAP (LOGAND 177 (SETQ L1-MAP (aref lam-level-1-map-array ADR))))
    (STORE (LAM-LEVEL-1-MAP-FREQUENCIES MASKED-L1-MAP)
	   (SETQ TEM (1+ (LAM-LEVEL-1-MAP-FREQUENCIES MASKED-L1-MAP))))
    (COND ((AND (NOT (= MASKED-L1-MAP 177))	 ;NO LEVEL 1 MAP ENTRYS SHOULD BE DUPLICATED
		(NOT (= TEM 1)))	 ; EXCEPT 177
	   (FORMAT T "~%TRIGGERED ON L1-MAP ~O, FREQ ~O" L1-MAP TEM)
	   (SETQ PRINT-MAP-FREQS T)))
    (STORE (LAM-LEVEL-1-REVERSE-MAP MASKED-L1-MAP)
	   ADR))
  (COND (PRINT-MAP-FREQS
	 (DO ((I 0 (1+ I)))
	     ((= I 128.))
	   (FORMAT T "~%LEVEL-1-MAP-VALUE ~S APPEARS ~S" I (LAM-LEVEL-1-MAP-FREQUENCIES I)))))
  (DO ((I 0 (1+ I))
       (NOT-177S 0))
      ((= I 127.)
       (FORMAT T "~%NOT-177S ~s" NOT-177S))
    (SETQ TEM (LAM-LEVEL-1-MAP-FREQUENCIES I))
    (SETQ NOT-177S (+ NOT-177S TEM))
    (COND ((ZEROP TEM)
	   (FORMAT T "~%LEVEL-2-MAP-BLOCK ~S NOT-USED" I)
	   (GO E))
	  ((> TEM 1)
	   (FORMAT T "~%LEVEL-2-MAP-BLOCK ~S USED ~S TIMES" I TEM)))
    (SETQ NUM-CHECKED-OK 
	  (+ (LAM-CHECK-LEVEL-2-BLOCK-bulk (ASH (LAM-LEVEL-1-REVERSE-MAP I) 13.)
				      I)
	     NUM-CHECKED-OK))
    E)
  (FORMAT T "~%MAP-ENTRIES-CHECKED-OK ~S" NUM-CHECKED-OK)
  (RETURN NIL)))

(DEFUN LAM-CHECK-LEVEL-2-BLOCK-bulk (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
 (PROG (L2M-CONTROL L2M-PHYSICAL-ADDRESS L2M-CONTROL-SHIFTED
	PHT-ADR VIR-ADR NUM-CHECKED-OK L2MAP-SA)
   (SETQ NUM-CHECKED-OK 0)
   (SETQ L2MAP-SA (LSH LEVEL-2-BLOCK-NUMBER 5))
   (DO ADR-IN-BLOCK 0 (1+ ADR-IN-BLOCK) (= ADR-IN-BLOCK 32.)
       (SETQ L2M-CONTROL (aref lam-level-2-map-control-array (+ ADR-IN-BLOCK L2MAP-SA)))
       (SETQ L2M-PHYSICAL-ADDRESS
	     (aref lam-level-2-map-physical-page-array (+ ADR-IN-BLOCK L2MAP-SA)))
       (SETQ L2M-CONTROL-SHIFTED (ASH L2M-CONTROL 16))  ;shift into position so CADR %% byte
		;definitions will work.
       (COND ((>= (LDB %%PHT2-MAP-STATUS-CODE L2M-CONTROL-SHIFTED)  ;IF LEVEL 2 MAP SET UP ...
		  %PHT-MAP-STATUS-READ-ONLY)
	      (SETQ PHT-ADR (QF-PAGE-HASH-TABLE-LOOKUP
			     (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
	      (COND ((< PHT-ADR 0)
		     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS)
			    (FORMAT T "~%Map entry at virtual address ~s not found in pht"
				    VIR-ADR)
			    (FORMAT T "~% map-value ~s level-2-map-adr ~s"
				    L2M-CONTROL-SHIFTED
				    (+ (LSH LEVEL-2-BLOCK-NUMBER
					    5)
				       ADR-IN-BLOCK)))))
		    (T
		     (LET* ((PHT1-VALUE (PHYS-MEM-READ PHT-ADR))
			    (PHT2-VALUE (PHYS-MEM-READ (1+ PHT-ADR)))
			    (NUBUS-PAGE (LDB 0026 L2M-PHYSICAL-ADDRESS))
			    (HARDWARE-VIRTUAL-ADDRESS-PAGE
			      (NUBUS-PAGE-TO-HARDWARE-VIRTUAL-ADDRESS-PAGE NUBUS-PAGE)))
		       (COND ((NULL HARDWARE-VIRTUAL-ADDRESS-PAGE)
			      (FORMAT T "~%Map entry at virtual address ~s cannot be mapped to a hardware virtual address.  It was found in PHT!"
				      VIR-ADR)
			      (FORMAT T "~% L2M control ~s, L2M phys-page ~s, pht1 ~s, pht2 ~s"
				      L2M-CONTROL
				      L2M-PHYSICAL-ADDRESS
				      PHT1-VALUE
				      PHT2-VALUE))
			     ((NOT (= HARDWARE-VIRTUAL-ADDRESS-PAGE
				      (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2-VALUE)))
			      (format t "~%Map entry at virtual address ~S maps into hardware virtual address which does not compare with PHT2"
				      vir-adr)
			      (format t "~%  Hardware-virtual-page-number of map ~s, pht2 ~s"
				      HARDWARE-VIRTUAL-ADDRESS-PAGE
				      PHT2-VALUE)
			      (FORMAT T "~%  PHT1 ~s, PHT-ADDR ~s, L2M-CONTROL-SHIFTED ~s, L2 map adr ~s"
				      PHT1-VALUE
				      PHT-ADR 
				      L2M-CONTROL-SHIFTED
				      (+ (LSH LEVEL-2-BLOCK-NUMBER
					      5)
					 ADR-IN-BLOCK)))
			     ((NOT (= (LDB %%PHT2-META-BITS L2M-CONTROL-SHIFTED)
				      (LDB %%PHT2-META-BITS PHT2-VALUE)))
			      (FORMAT T "~%MAP-ENTRY-AT-VIRTUAL-ADDRESS ~s META-BITS-DIFFER"
				      VIR-ADR)
			      (format t "~%Map value ~s, PHT2 ~s, pht adr ~S, level-2-map adr ~s"
				      L2M-CONTROL-SHIFTED
				      PHT2-VALUE 
				      PHT-ADR 
				      (+ (LSH LEVEL-2-BLOCK-NUMBER
					      5)
					 ADR-IN-BLOCK)))
			     (T (SETQ NUM-CHECKED-OK (1+ NUM-CHECKED-OK))))))))))
   (RETURN NUM-CHECKED-OK)))

(DEFUN (:PROPERTY check-reverse-level-2-map-bulk lam-colon-cmd) (ignore)
  (dotimes (idx 177)
    (let* ((mach (lam-register-examine (+ raamo 2000 idx)))
	   (mach-l1-idx (ash mach -13.)))
      (cond ((not (< mach-l1-idx 10000))
	     (format t "~%idx for ~s is too large" idx))
	    (t
	     (let ((mach-l1 (aref lam-level-1-map-array mach-l1-idx)))
	       (cond ((not (= (logand mach-l1 177) idx))
		      (format t "~%idx ~s, l1-idx ~s, but is ~s"
			      idx mach-l1-idx mach-l1)))))))))



;:MEMSTAT TELL ALL ABOUT ALL PAGES THAT ARE SWAPPED IN
(DEFUN (:PROPERTY MEMSTAT LAM-COLON-CMD) (TEM)
  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
  ; META BITS, MAP STATUS, ACCESS CODE 
  (DO ((L (LAM-DESCRIBE-MEMORY-COLLECT-CONTIG (LAM-DESCRIBE-MEMORY-COPY-OUT-PHT) NIL)
	  (CDR L)))
      ((NULL L))				;PROCESS EACH CONTIG AREA
    (DO ((LL (LAM-DESCRIBE-MEMORY-CONTIG-SPLITUP (NREVERSE (CAR L)) NIL)
	     (CDR LL)))
	((NULL LL))
      (PRINT (CAAAR LL))				;FIRST VIRTUAL ADDRESS
      (TYO #/TAB)
      (COND ((< (CADAAR LL) (LENGTH AREA-LIST))		;PRINT AREA NAME, TRYING TO BE
	     (PRIN1-THEN-SPACE (NTH (CADAAR LL) AREA-LIST)))	;QUICK ABOUT IT
	    (T (LAM-Q-PRINT-TOPLEV (QF-MEM-READ (+ (CADAAR LL)
						  (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))))
	       (TYO #/space)))
      (PRIN1 (// (- (CAAAR LL)
		     (SETQ TEM (QF-POINTER		;AREA NUMBER TO AREA ORIGIN
				 (QF-MEM-READ (+ (CADAAR LL)
						 (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN))))))
		  PAGE-SIZE))				;FIRST RELATIVE PAGE NUM
      (COND ((> (LENGTH (CAR LL)) 1)			;IF MULTI PAGES CONTIG
	     (PRINC '-)
	     (PRIN1 (// (- (CAAR (LAST (CAR LL))) TEM) PAGE-SIZE))))
      (PRINC "  -->  ")				;MAPS ONTO
      (LAM-DESCRIBE-MEMORY-PRINT-ATTRIB (CAAR LL))))	;SAY WHAT IT MAPS ONTO
  (TERPRI)
  NIL)

(DEFUN LAM-DESCRIBE-MEMORY-PRINT-ATTRIB (X)
  (PRIN1-THEN-SPACE (CADDDR X))				;PHYSICAL ADDRESS
  (AND (CADDR X) (PRIN1-THEN-SPACE (CADDR X)))		;SWAP STATUS IF ABNORMAL
  (PRIN1-THEN-SPACE (CADR (CDDDDR X)))			;MAP STATUS
  (AND (CADDR (CDDDDR X))
       (PRIN1-THEN-SPACE (CADDR (CDDDDR X))))		;ACCESS IF ANY
  (OR (= 0 (CAR (CDDDDR X)))
      (PRIN1 'META-BITS=)
      (PRIN1 (CAR (CDDDDR X)))))			;META BITS IF NON-ZERO

  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
  ; META BITS, MAP STATUS, ACCESS CODE 
;CONVERT ONE LIST OF PAGES INTO N, FOR THE CONTIGUOUS SUBSETS
(DEFUN LAM-DESCRIBE-MEMORY-CONTIG-SPLITUP (LL PREV-CONTIG)
  (COND ((NULL PREV-CONTIG)
	 (LAM-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL))))
	((NULL LL)
	 (LIST (NREVERSE PREV-CONTIG)))
	((AND (= (- (CADDDR (CAR LL)) PAGE-SIZE)
		 (CADDDR (CAR PREV-CONTIG)))	;PHYS ADDRS AGREE
	      (EQ (CADDR (CAR LL)) (CADDR (CAR PREV-CONTIG)))	;SWAP STATUS AGREE
	      (EQUAL (CDDDDR (CAR LL)) (CDDDDR (CAR PREV-CONTIG)))) ;OTHER STUFF AGREES
	 (LAM-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (CONS (CAR LL) PREV-CONTIG)))
	(T							;START NEW CONTIG FROB
	 (CONS (NREVERSE PREV-CONTIG)
	       (LAM-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL)))))))

(DEFUN LAM-DESCRIBE-MEMORY-COLLECT-CONTIG (SORTED-PHT-LIST PREVIOUS-CONTIG-LIST)
  (COND ((NULL SORTED-PHT-LIST)
	 (AND PREVIOUS-CONTIG-LIST (LIST PREVIOUS-CONTIG-LIST)))
	((NULL PREVIOUS-CONTIG-LIST)
	 (LAM-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
					    (LIST (CAR SORTED-PHT-LIST))))
	((AND (= (CADAR SORTED-PHT-LIST) (CADAR PREVIOUS-CONTIG-LIST)) ;SAME AREA
	      (= (CAAR SORTED-PHT-LIST)
		 (+ PAGE-SIZE (CAAR PREVIOUS-CONTIG-LIST)))) ;NEXT VIR ADR
	 (LAM-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
					    (CONS (CAR SORTED-PHT-LIST) PREVIOUS-CONTIG-LIST)))
	(T
	 (CONS PREVIOUS-CONTIG-LIST
	       (LAM-DESCRIBE-MEMORY-COLLECT-CONTIG SORTED-PHT-LIST NIL)))))

(proclaim '(SPECIAL %PHT-DUMMY-VIRTUAL-ADDRESS %%QF-PHT1-VIRTUAL-PAGE-NUMBER))

(DEFUN LAM-DESCRIBE-MEMORY-COPY-OUT-PHT NIL 
  (SORTCAR
    (DO ((PHTP (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-PNTR))) (+ PHTP 2))
	 (COUNT (// (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) 2)
		(1- COUNT))
	 (PHT1)
	 (PHT2)
	 (VIRAD)
	 (LST NIL))
	((= 0 COUNT) LST)
      (DECLARE (FIXNUM PHTP COUNT PHT1 PHT2 VIRAD))
      (COND ((AND (NOT (= 0 (LOGAND 100 (SETQ PHT1 (PHYS-MEM-READ PHTP)))))
		  (NOT (= %QF-PHT-DUMMY-VIRTUAL-ADDRESS (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1))))
	     (SETQ LST (CONS (LIST (SETQ VIRAD (* PAGE-SIZE		;VIRTUAL ADDRESS
						  (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)))

				   (QF-AREA-NUMBER-OF-POINTER VIRAD)	;AREA NUMBER
				   (NTH (LDB %%PHT1-SWAP-STATUS-CODE PHT1)
					'(SWAP-STATUS-ZERO?
					  NIL FLUSHABLE SWAP-STATUS-PDL-BUFFER
					  AGE-TRAP WIRED SWAP-STATUS-6?
					  SWAP-STATUS-7?))
				   (* PAGE-SIZE		;PHYSICAL ADDRESS
				      (LDB %%PHT2-PHYSICAL-PAGE-NUMBER
					      (SETQ PHT2 (PHYS-MEM-READ (1+ PHTP)))))
				   (LDB %%PHT2-META-BITS PHT2)
				   (NTH (LDB %%PHT2-MAP-STATUS-CODE PHT2)
					'(LEVEL-1-MAP-NOT-VALID?
					  LEVEL-2-MAP-NOT-VALID?
					  READ-ONLY READ-WRITE-FIRST READ-WRITE
					  MAP-STATUS-PDL-BUFFER
					  MAP-STATUS-6? MAP-STATUS-7?))
				   (NTH (LDB %%PHT2-MAP-ACCESS-CODE PHT2)
					'(NIL NIL R-ACCESS R-W-ACCESS)))
			     LST)))))
    (FUNCTION <)))

(defun current-lc-in-halfwords ()
  (logand (+ (ash %qf-pointer-mask 1) 1)
	  (selectq current-processor-type
	    (:lambda (ash (lam-symbolic-examine-register 'lc) -1))
	    (:explorer (lam-symbolic-examine-register 'lc)))))

(DEFUN (:PROPERTY RELPC LAM-COLON-CMD) (IGNORE)
  (PROG (M-AP LC)
	(SETQ M-AP (LAM-REGISTER-EXAMINE (+ (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
					   RAPBO)))
	(LAM-Q-PRINT-TOPLEV M-AP)
	(COND ((= (LDB %%QF-DATA-TYPE M-AP)
		  DTP-FEF-POINTER)
	       ;subtract because the lc has already been incremented
	       (setq lc (1- (current-lc-in-halfwords)))
	       (format t " ")
	       (PRIN1 (- lc
			 (* 2 (QF-POINTER M-AP)))) ))))

(proclaim '(SPECIAL %%LP-EXS-EXIT-PC %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 
		    %%LP-CLS-DELTA-TO-OPEN-BLOCK 
		    %%LP-ENS-NUM-ARGS-SUPPLIED))

(DEFUN (:PROPERTY TRACE LAM-COLON-CMD) (COUNT)
     (LAM-TRACE-COMMAND COUNT T))

(defun (:property trace-with-binds lam-colon-cmd) (count)
  (lam-trace-command count t t))

(DEFUN (:PROPERTY TRACEN LAM-COLON-CMD) (COUNT)
     (LAM-TRACE-COMMAND COUNT NIL))

(DEFUN LAM-TRACE-COMMAND (COUNT PRINT-ARGS-P &optional print-bind-stack)
    (TERPRI)
    (LAM-TRACE-THE-STACK (COND ((NULL COUNT)
			       (SETQ COUNT 7777777)
			       (COND ((AND LAM-LAST-VALUE-TYPED
					   (= (QF-DATA-TYPE LAM-LAST-VALUE-TYPED)
					      DTP-STACK-GROUP))
				      LAM-LAST-VALUE-TYPED)
				     (T T)))
			      ((MINUSP COUNT)
			       (SETQ COUNT (- COUNT))
			       NIL)
			      (T T))
			PRINT-ARGS-P
			COUNT
			print-bind-stack))

;; First argument, MODE, is NIL to use the current stack group from the pdl buffer,
;; T for the current stack group from memory, or a stack group to trace.
;; Second argument, PRINT-ARGS-P, is T if you want the arguments to be printed
;; for each frame.
(DEFUN LAM-TRACE-THE-STACK (MODE PRINT-ARGS-P COUNT &optional (print-bind-stack nil))
    (PROG (M-AP CALL-WORD EXIT-WORD ENTRY-WORD FUNCTION-WORD FRAME-TYPE TIMES
	   lam-stack-a-QLBNDP lam-stack-a-qlbndo top-level-m-flags
	   set-frame-exists-flags)
	  (SETQ TIMES 0)
	  (SETQ M-AP
		 (COND ((NULL MODE)
			(+ RAPBO (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-AP)))
		       ((EQ MODE T)
			(+ (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER
					'A-PDL-BUFFER-VIRTUAL-ADDRESS))
			   (LOGAND 3777 (- (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
					   (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER
							'A-PDL-BUFFER-HEAD))))))
		       (T (SETQ MODE (QF-MAKE-Q MODE DTP-ARRAY-POINTER))
			  (LET ((RP (QF-ARRAY-LEADER MODE SG-REGULAR-PDL)))
			    (QF-POINTER
			      (+ RP
			       (QF-ARRAY-LEADER MODE SG-AP)
			       1
			       (LDB %%ARRAY-LONG-LENGTH-FLAG (LAM-MEM-READ RP))))))))
	  (setq lam-stack-a-qlbndp
		(qf-pointer
		  (cond ((or (null mode)
			     (eq mode t))
			 (setq lam-stack-a-qlbndo
			       (qf-pointer
				 (lam-symbolic-examine-register 'a-qlbndo)))
			 (lam-symbolic-examine-register 'a-qlbndp))
			(t (let ((sp (qf-array-leader mode sg-special-pdl)))
;			     (setq lam-stack-a-qlbndo
;				   (qf-pointer
;				     (+ (qf-array-leader mode sg-special-pdl-pointer)
;					1
;					(ldb %%array-long-length-flag (lam-mem-read sp)))))
			     (setq lam-stack-a-qlbndo (qf-pointer (+ sp 1
								     (ldb %%array-long-length-flag (lam-mem-read sp)))))
			     
			     (+ sp
				(qf-array-leader mode sg-special-pdl-pointer)
				1
				(ldb %%array-long-length-flag (lam-mem-read sp))))))))
	  (setq top-level-m-flags
		(cond ((or (null mode)
			   (eq mode t))
		       (lam-symbolic-examine-register 'm-flags))
		      (t (qf-array-leader mode sg-saved-m-flags))))

	  (COND ((NULL MODE) 
		 (SETQ FUNCTION-WORD (LAM-REGISTER-EXAMINE M-AP)))
		(T
		 (SETQ FUNCTION-WORD (LAM-MEM-READ M-AP))))
	  (SETQ FRAME-TYPE (NTH (LDB %%QF-DATA-TYPE FUNCTION-WORD) Q-DATA-TYPES))

	(SETQ LAM-STACK-SVAR-FRAME-EXISTS NIL)
	(COND ((EQ FRAME-TYPE 'DTP-FEF-POINTER)
		(SETQ LAM-STACK-SVAR-FRAME-EXISTS
			 (NOT (ZEROP (LOGLDB %%M-FLAGS-QBBFL top-level-m-flags))))))
	LOOP
	  (OR (NOT (send *terminal-io* :tyi-no-hang)) (RETURN NIL))
	  (COND ((NULL MODE) 
		 (SETQ CALL-WORD (LAM-REGISTER-EXAMINE (- M-AP 3)))
		 (SETQ EXIT-WORD (LAM-REGISTER-EXAMINE (- M-AP 2)))
		 (SETQ ENTRY-WORD (LAM-REGISTER-EXAMINE (- M-AP 1)))
		 (SETQ FUNCTION-WORD (LAM-REGISTER-EXAMINE M-AP)))
		(T
		 (SETQ CALL-WORD (LAM-MEM-READ (- M-AP 3)))
		 (SETQ EXIT-WORD (LAM-MEM-READ (- M-AP 2)))
		 (SETQ ENTRY-WORD (LAM-MEM-READ (- M-AP 1)))
		 (SETQ FUNCTION-WORD (LAM-MEM-READ M-AP))))
	  (SETQ FRAME-TYPE (NTH (LDB %%QF-DATA-TYPE FUNCTION-WORD) Q-DATA-TYPES))
	  (setq lam-stack-current-frame-type frame-type)

	  (cond (set-frame-exists-flags  ;true except first time around.
		 (SETQ LAM-STACK-SVAR-FRAME-EXISTS
		       (ldb-test %%LP-EXS-BINDING-BLOCK-PUSHED exit-word))))

	  (SETQ LAM-STACK-UPDL-FRAME-EXISTS
		(ldb-test %%LP-EXS-MICRO-STACK-SAVED exit-word))

	  ;;; Print out info about this frame.
	  (format t "~&")
	  (PRIN1-THEN-SPACE M-AP)

 ;	  (CONDITION-CASE (ERROR)
 ;	      (LAM-Q-PRINT-TOPLEV FUNCTION-WORD)
 ;	    (ERROR (SEND ERROR :PRINT-ERROR-MESSAGE CURRENT-STACK-GROUP T *STANDARD-OUTPUT*)))
	  (LAM-Q-PRINT-TOPLEV FUNCTION-WORD)
	  (COND ((AND (EQ FRAME-TYPE 'DTP-FEF-POINTER)
		      (NOT (AND (ZEROP TIMES)
				(MEMQ MODE '(T NIL)))))
		 (format t "[~S]" (LDB %%LP-EXS-EXIT-PC EXIT-WORD))
		 (cond ((and (boundp '%%lp-cls-attention)
			     (ldb-test %%lp-cls-attention call-word))
			(format t "{ATT}")))
		 (cond ((ldb-test %%lp-cls-self-map-provided call-word)
			(format t "{SM}")))
		 (cond ((ldb-test %%lp-cls-adi-present call-word)
			(format t "{ADI}")))
		 (cond ((ldb-test %%lp-exs-binding-block-pushed exit-word)
			(format t "{Binding Block}")))
		 (cond ((ldb-test %%lp-exs-micro-stack-saved exit-word)
			(format t "{micro-stack saved}")
			))
		 ))
	  (COND (PRINT-ARGS-P
		 (DO ((ADR (1+ M-AP) (1+ ADR))
		      (LAM-SEXP-PRINLEVEL 2)
		      (LAM-SEXP-PRINLENGTH 3)
		      (CNT (LDB %%LP-ENS-NUM-ARGS-SUPPLIED ENTRY-WORD) (1- CNT)))
		     ((ZEROP CNT))
		   (DECLARE (FIXNUM ADR CNT))
		   (tyo #/space)
;		   (CONDITION-CASE (ERROR)
;		       (LAM-Q-PRINT-TOPLEV (COND ((NULL MODE) (LAM-REGISTER-EXAMINE ADR))
;						(T (LAM-MEM-READ ADR))))
;		     (ERROR (SEND ERROR :PRINT-ERROR-MESSAGE
;				  CURRENT-STACK-GROUP T *STANDARD-OUTPUT*)))
		   (LAM-Q-PRINT-TOPLEV (COND ((NULL MODE) (LAM-REGISTER-EXAMINE ADR))
					     (T (LAM-MEM-READ ADR)))))))
	  (TERPRI)
	
	  (OR (< (SETQ TIMES (1+ TIMES)) COUNT)
	      (RETURN NIL))
	  (lam-stack-space-bind-stack print-bind-stack)
	  (setq set-frame-exists-flags t)
	  (LET ((DELTA (LDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK CALL-WORD)))
	    (COND ((ZEROP DELTA) (RETURN NIL))
		  (T (SETQ M-AP (- M-AP DELTA))
		     (GO LOOP))))
	  ))

(proclaim '(SPECIAL %%FEFH-PC %FEFHI-IPC %FEFHI-STORAGE-LENGTH))

(DEFUN (:PROPERTY CODE LAM-COLON-CMD) (ARG)
   (TERPRI)
   (LET ((LC (current-lc-in-halfwords)))
     (LET ((PC (COND (LAM-OPEN-REGISTER 0)
		     (T			;subtract because lc has already been incremented
		      (1- LC))))
	   (FEF (COND (LAM-OPEN-REGISTER (LAM-REGISTER-EXAMINE LAM-OPEN-REGISTER))
		      (T (LAM-REGISTER-EXAMINE (+ (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
						  RAPBO))))))
       (DECLARE (FIXNUM PC FEF))
       (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER))
	      (PRINC "The current function is not a FEF.") (TERPRI))
	     (T (SETQ FEF (QF-POINTER FEF))
		(PRINC (COND (LAM-OPEN-REGISTER "FEF is ")
			     (T "Current FEF is ")))
		(LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (+ %FEFHI-FCTN-NAME FEF)))
		(TERPRI)
		(LET ((RELPC (- PC (* 2 FEF))))
		  (DECLARE (FIXNUM RELPC))
		  (COND ((AND (NULL LAM-OPEN-REGISTER) (OR (< RELPC 10) (> RELPC 10000)))
			 (PRINC "The PC does not seem to be pointer to the running FEF.")
			 (TERPRI))
			(T (LAM-DISASSEMBLE-FEF FEF
						(COND ((OR LAM-OPEN-REGISTER (EQ ARG 1)) NIL)
						      (T RELPC)))))))))))

(DEFUN (:PROPERTY DISASSEMBLE-FEF LAM-COLON-CMD) (ARG)
  ARG
  (AND LAM-LAST-VALUE-TYPED
       (= (QF-DATA-TYPE LAM-LAST-VALUE-TYPED) DTP-FEF-POINTER)
       (PROGN (PRINC "Type center PC or NIL")
	      (LAM-DISASSEMBLE-FEF LAM-LAST-VALUE-TYPED (READ)))))

(defvar *pdl-transitions*)  ;alist of PC and PDL-level.

(DEFUN LAM-DISASSEMBLE-FEF (FEF CENTER-PC)
  (LET ((LIM-PC (QF-FEF-LIMIT-PC FEF))
	*pdl-transitions* ILEN pdl-change)
    (DO ((PC (QF-FEF-INITIAL-PC FEF) (+ PC ILEN))
	 (relative-pdl-level 0)
	 wd)
	((>= PC LIM-PC))
      (AND CENTER-PC (> PC (+ CENTER-PC 20.))
	   (RETURN NIL))
      (SETQ WD (QF-FEF-INSTRUCTION FEF PC))
      (let ((print-flag (OR (NULL CENTER-PC)
			    ( (- CENTER-PC 20.) PC))))
	(if print-flag (format t "~%~:[  ~;=>~]" (EQ PC CENTER-PC)))
	(multiple-value (ILEN pdl-change)
	  (LAM-DISASSEMBLE-INSTRUCTION wd FEF PC print-flag))
	(setq relative-pdl-level (+ relative-pdl-level pdl-change)))
      ))
  (TERPRI) (TERPRI))

;pdl tracking feature not fully implemented yet...
(DEFUN LAM-DISASSEMBLE-INSTRUCTION (WD FEF PC PRINT-FLAG &AUX (*PRINT-BASE* 8.)
				   OP SUBOP DEST REG DISP ILEN pdl-change SECOND-WORD)
  "Print on *STANDARD-OUTPUT* the disassembly of the instruction at PC in FEF.
Returns the length of that instruction."
  (setq ILEN (QF-FEF-INSTRUCTION-LENGTH WD FEF PC)
	pdl-change 0)
  (PROG NIL  ;PROG so that RETURN can be used to return unusual instruction lengths. 
	(when print-flag (PRIN1 PC) (TYO 40))
    (SETQ OP (LDB 1104 WD)	;reset below for new ops.
	  SUBOP (LDB 1503 WD)
	  DEST (LDB 1602 WD)
	  DISP (LDB 0011 WD)
	  REG (LDB 0603 WD))
    (COND ((= ILEN 2)
	   (SETQ PC (1+ PC))
	   (SETQ SECOND-WORD (QF-FEF-INSTRUCTION FEF PC))
	   ;; If a two-word insn has a source address, it must be an extended address,
	   ;; so set up REG and DISP to be right for that.
	   (UNLESS (= OP 14)
	     (SETQ REG (LDB 0603 SECOND-WORD)
		   DISP (DPB (LDB 1104 SECOND-WORD)
			     0604 (LDB 0006 SECOND-WORD))))))
    (WHEN (< OP 11) (SETQ OP (LDB 1105 WD)))
    (COND ((ZEROP WD)
	   (when print-flag (PRINC "0")))
	  ((< OP 11)     ;DEST/ADDR 
	   (when print-flag
	     (PRINC (NTH OP '(CALL CALL0 MOVE CAR CDR CADR CDDR CDAR CAAR)))
	     (TYO 40)
	     (PRINC (NTH DEST '(D-IGNORE D-PDL D-RETURN D-LAST))))
	   (setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS print-flag FEF REG DISP SECOND-WORD)
			       pdl-change)))
	  ((= OP 11)	    ;ND1
	   (when print-flag
	     (PRINC (NTH SUBOP '(ND1-UNUSED + - * // LOGAND LOGXOR LOGIOR))))
	   (setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS print-flag FEF REG DISP SECOND-WORD)
			       pdl-change)))
	  ((= OP 12)	    ;ND2
	   (when print-flag
	     (PRINC (NTH SUBOP '(= > < EQ SETE-CDR SETE-CDDR SETE-1+ SETE-1-))))
	   (setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS print-flag FEF REG DISP SECOND-WORD)
			       pdl-change)))
	  ((= OP 13)	    ;ND3
	   (when print-flag
	     (PRINC (NTH SUBOP '(BIND-OBSOLETE? BIND-NIL BIND-POP SET-NIL SET-ZERO PUSH-E MOVEM POP))))
	   (setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS print-flag FEF REG DISP SECOND-WORD)
			       pdl-change)))
	  ((= OP 14)	    ;BRANCH
	   (when print-flag
	     (PRINC (NTH SUBOP '(BR BR-NIL BR-NOT-NIL BR-NIL-POP
				    BR-NOT-NIL-POP BR-ATOM BR-NOT-ATOM BR-ILL-7)))
	     (TYO 40))
	   (AND (> DISP 400) (SETQ DISP (LOGIOR -400 DISP))) ;SIGN-EXTEND
	   (when print-flag
	     (COND ((NEQ DISP -1)	    ;ONE WORD
		    (PRIN1 (+ PC DISP 1)))
		   (T				;LONG BRANCH
		    (SETQ DISP SECOND-WORD)
		    (AND (>= DISP 100000) (SETQ DISP (LOGIOR -100000 DISP)))
		    (PRINC "LONG ")
		    (PRIN1 (+ PC DISP 1))
		    (RETURN)))))
	  ((= OP 15)	    ;MISC
	   (IF (BIT-TEST 1 SUBOP)
	       (SETQ DISP (+ DISP 1000)))
	   (when print-flag (PRINC "(MISC) ")) ;Moon likes to see this
	   (COND ((< DISP 200)
		  (when print-flag
		    (FORMAT T "~A (~D) "
			  (NTH (LDB 0403 DISP)
			       '(AR-1 ARRAY-LEADER %INSTANCE-REF UNUSED-AREFI-3
				 AS-1 STORE-ARRAY-LEADER %INSTANCE-SET UNUSED-AREFI-7))
			  (+ (LDB 0004 DISP)
			     (IF (= (LDB 0402 DISP) 2) 1 0)))))
		 ((< DISP 220)
		  (when print-flag
		    (FORMAT T "UNBIND ~D binding~:P " (- DISP 177)))  ;code 200 does 1 unbind.
		  (AND (ZEROP DEST) (RETURN)))
		 ((< DISP 240)
		  (when print-flag
		    (FORMAT T "POP-PDL ~D time~:P " (- DISP 220))) ;code 220 does 0 pops.
		  (AND (ZEROP DEST) (RETURN)))
		 ((= DISP 460)  ;(GET 'INTERNAL-FLOOR-1 'QLVAL)
		  (when print-flag
		    (PRINC (NTH DEST '(FLOOR CEILING TRUNCATE ROUND)))
		    (PRINC " one value to stack"))
		  (SETQ DEST NIL))
		 ((= DISP 510)  ;(GET 'INTERNAL-FLOOR-2 'QLVAL)
		  (when print-flag
		    (PRINC (NTH DEST '(FLOOR CEILING TRUNCATE ROUND)))
		    (PRINC " two values to stack"))
		  (SETQ DEST NIL))
		 (T
                  (LET ((OP (QF-MEM-READ
			      (+ (QF-INITIAL-AREA-ORIGIN 'MICRO-CODE-SYMBOL-NAME-AREA)
				 (- DISP 200)))))
		    (when print-flag
		      (COND ((NULL OP) (FORMAT T "#~O " DISP))
			    (T (LAM-Q-PRINT-STRING (LAM-MEM-READ OP)) (TYO #/space)))))))
	   (when DEST
	     (when print-flag (PRINC (NTH DEST '(D-IGNORE D-PDL D-RETURN D-LAST))))))
	  ((= OP 16)	    ;ND4
	   (SELECTQ SUBOP
	     (0 (when print-flag (FORMAT T "STACK-CLOSURE-DISCONNECT  local slot ~D" DISP)))
	     (1 (LET ((LOCALNUM
			(LDB 0012
			     (QF-NTH DISP
				     (QF-MEM-READ
				       (+ FEF (- (LOGLDB %%FEFH-PC-IN-WORDS (QF-MEM-READ FEF)) 2)))))))
		  (when print-flag
		    (FORMAT T "STACK-CLOSURE-UNSHARE LOCAL:~D" LOCALNUM)
		    (LET ((TEM (LAM-DISASSEMBLE-LOCAL-NAME FEF LOCALNUM)))
		      (WHEN TEM
			(FORMAT T " ~30,8T;")
			(LAM-Q-PRINT-TOPLEV TEM))))))
	     (2 (when print-flag (FORMAT T "MAKE-LEXICAL-CLOSURE  local slot ~D" DISP)))
	     (3 (when print-flag (FORMAT T "PUSH-NUMBER ~S" DISP)))
	     (4 (when print-flag
		  (FORMAT T "STACK-CLOSURE-DISCONNECT-FIRST  local slot ~D" DISP)))
	     (5 (when print-flag (FORMAT T "PUSH-CDR-IF-CAR-EQUAL "))
		(setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS
				      print-flag FEF REG DISP SECOND-WORD PC)
				    pdl-change)))
	     (6 (when print-flag (FORMAT T "PUSH-CDR-STORE-CAR-IF-CONS "))
		(setq pdl-change (+ (LAM-DISASSEMBLE-ADDRESS
				      print-flag FEF REG DISP SECOND-WORD PC)
				    pdl-change)))
	     (T (when print-flag (FORMAT T "UNDEF-ND4-~D ~D" SUBOP DISP)))))
	  ((= OP 20)
	   (when print-flag
	     (FORMAT T "~A (~D) "
		   (NTH REG
			'(AR-1 ARRAY-LEADER %INSTANCE-REF COMMON-LISP-AR-1
			  SET-AR-1 SET-ARRAY-LEADER SET-%INSTANCE-REF UNUSED-AREFI))
		   (+ (LDB 0006 DISP)
		      (IF (MEMQ REG '(2 6)) 1 0)))
	     (PRINC (NTH DEST '(D-IGNORE D-PDL D-RETURN D-LAST)))))
	  ((= op 21)
	   (setq subop (ash subop -1))
	   (when print-flag
	     (princ (nth subop '(1+ 1- error error)))
	     (tyo 40))
	   (lam-disassemble-address print-flag fef reg disp second-word))
	  (T		    ;UNDEF
	   (when print-flag
	     (PRINC 'UNDEF-)
	     (PRIN1 OP)))))
  (values ILEN pdl-change))

(DEFUN LAM-DISASSEMBLE-ADDRESS (print-flag FEF REG DISP &OPTIONAL SECOND-WORD PC
			    &AUX TEM)
  "Print out the disassembly of an instruction source address.
REG is the register number of the address, and DISP is the displacement.
SECOND-WORD should be the instruction's second word if it has two.
PC should be where the instruction was found in the FEF.
Value is change of stack"
  (when print-flag (TYO 40))
  ;; In a one-word instruction, the displacement for types 4 thru 7 is only 6 bits,
  ;; so ignore the rest.  In a two word insn, we have been fed the full disp from word 2.
  (IF (AND (>= REG 4) (NOT SECOND-WORD))
      (SETQ DISP (LOGAND 77 DISP)))
  (COND ((< REG 4)
         (when print-flag
	   (FORMAT T "FEF|~D ~30,8T;" DISP)
	   (LAM-DISASSEMBLE-POINTER FEF DISP PC))
	 0)
	((= REG 4)
	 (when print-flag
	   (tyo #/')
	   (SETQ TEM (LAM-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'CONSTANTS-AREA) DISP)))
	   (IF (= (QF-DATA-TYPE TEM) DTP-SYMBOL)
	       (LAM-Q-PRINT-STRING (LAM-MEM-READ TEM))
	     (LAM-Q-PRINT-TOPLEV TEM)))
	 0)
        ((= REG 5)
	 (when print-flag
	   (FORMAT T "LOCAL|~D" DISP)
	   (SETQ TEM (LAM-DISASSEMBLE-LOCAL-NAME FEF DISP))
	   (WHEN TEM
	     (FORMAT T " ~30,8T;")
	     (LAM-Q-PRINT-STRING (LAM-MEM-READ TEM))))
	 0)
        ((= REG 6)
	 (when print-flag
	   (FORMAT T "ARG|~D" DISP)
	   (SETQ TEM (LAM-DISASSEMBLE-ARG-NAME FEF DISP))
	   (WHEN TEM
	     (FORMAT T " ~30,8T;")
	     (LAM-Q-PRINT-STRING (LAM-MEM-READ TEM))))
	 0)
	((AND (NOT SECOND-WORD) (= DISP 77))
	 (when print-flag
	   (PRINC 'PDL-POP))
	 1)
	((< DISP 40)
	 (when print-flag
	   (FORMAT T "SELF|~D" DISP)
	   (SETQ TEM (LAM-DISASSEMBLE-INSTANCE-VAR-NAME FEF DISP))
	   (WHEN TEM
	     (FORMAT T " ~30,8T;")
	     (LAM-Q-PRINT-STRING (LAM-MEM-READ TEM))))
	 0)
	((< DISP 70)
	 (when print-flag
	   (FORMAT T "SELF-MAP|~D" (- DISP 40))
	   (SETQ TEM (LAM-DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME FEF (- DISP 40)))
	   (WHEN TEM
	     (FORMAT T " ~30,8T;")
	     (LAM-Q-PRINT-STRING (LAM-MEM-READ TEM))))
	 0)
	(T (when print-flag
	     (FORMAT T "PDL|~D (undefined)" DISP))
	   0)))

(DEFUN LAM-DISASSEMBLE-POINTER (FEF DISP PC &AUX CELL PTR OFFSET TEM)
  PC
  (COND ((= (QF-DATA-TYPE (QF-MEM-READ (+ FEF DISP))) DTP-SELF-REF-POINTER)
	 (MULTIPLE-VALUE-BIND (PTR COMPONENT-FLAVOR-FLAG)
	     (QF-FLAVOR-DECODE-SELF-REF-POINTER 
	       (QF-FEF-FLAVOR-NAME FEF)
	       (QF-POINTER (QF-MEM-READ (+ FEF DISP))))
	   (IF (NULL PTR)
	       (SETQ CELL "self-ref-pointer "
		     PTR (QF-POINTER (QF-MEM-READ (+ FEF DISP))))
	     (SETQ CELL (IF COMPONENT-FLAVOR-FLAG "mapping table for " ""))
	     (PRINC CELL)
	     (LAM-Q-PRINT-TOPLEV PTR)
	     (IF (EQUAL CELL "")
		 (PRINC " in SELF")))))
	((= (QF-DATA-TYPE (QF-MEM-READ (+ FEF DISP))) DTP-ONE-Q-FORWARD)
	 (SETQ PTR (LAM-FIND-LIST-OR-SYMBOL-HEADER
		     (SETQ TEM (QF-POINTER (QF-MEM-READ (+ FEF DISP)))))
	       OFFSET (QF-POINTER (- TEM PTR)))
	 (COND ((= (QF-DATA-TYPE (QF-MEM-READ PTR)) DTP-SYMBOL-HEADER)
		(SETQ PTR (QF-MAKE-Q PTR DTP-SYMBOL))
		(SETQ CELL (NTH OFFSET '("@+0?? " "" "#'"
					 "@PLIST-HEAD-CELL " "@PACKAGE-CELL "))))
	       (T
		(SETQ PTR (QF-TYPED-POINTER (QF-MEM-READ PTR)) CELL "#'")))
	 (PRINC CELL)
	 (LAM-Q-PRINT-TOPLEV PTR)
	 )
	(T
	 (tyo #/')
	 (LAM-Q-PRINT-TOPLEV (QF-TYPED-POINTER (QF-MEM-READ (+ FEF DISP)))))))

(DEFUN LAM-FIND-LIST-OR-SYMBOL-HEADER (PTR)
  (DO ((PTR1 (1- (QF-POINTER PTR)) (1- PTR1)))
      (())
    (COND ((= (QF-DATA-TYPE (QF-MEM-READ PTR1)) DTP-SYMBOL-HEADER)
	   (RETURN PTR1))
	  ((NOT (= (QF-CDR-CODE (QF-MEM-READ PTR1)) CDR-NEXT))
	   (RETURN (1+ PTR1))))))

;Given a fef and an instance variable slot number,
;find the name of the instance variable,
;if the fef knows which flavor is involved.
(DEFUN LAM-DISASSEMBLE-INSTANCE-VAR-NAME (FEF SLOTNUM)
  (LET ((FLAVOR (QF-GET (QF-CAR (QF-CDR (QF-ASSQ (QF-SYMBOL ':FLAVOR)
						 (QF-FEF-DEBUGGING-INFO FEF))))
			(QF-SYMBOL 'SI:FLAVOR))))
    (AND FLAVOR (QF-NTH SLOTNUM (QF-FLAVOR-ALL-INSTANCE-VARIABLES FLAVOR)))))

(DEFUN LAM-DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME (FEF MAPSLOTNUM)
  (LET ((FLAVOR (QF-GET (QF-CAR (QF-CDR (QF-ASSQ (QF-SYMBOL ':FLAVOR)
						 (QF-FEF-DEBUGGING-INFO FEF))))
			(QF-SYMBOL 'SI:FLAVOR))))
    (AND FLAVOR (QF-NTH MAPSLOTNUM (QF-FLAVOR-MAPPED-INSTANCE-VARIABLES FLAVOR)))))

;; Given a fef and the number of a slot in the local block,
;; return the name of that local (or NIL if unknown).
;; If it has more than one name due to slot-sharing, we return a list of
;; the names, but if there is only one name we return it.
(DEFUN LAM-DISASSEMBLE-LOCAL-NAME (FEF LOCALNUM)
  (WHEN (= (QF-DATA-TYPE (QF-CURRENT-PACKAGE)) DTP-ARRAY-POINTER)
    (LET* ((FDI (QF-FEF-DEBUGGING-INFO FEF))
	   (AELT (QF-ASSQ (QF-SYMBOL 'COMPILER:LOCAL-MAP) FDI)))
      (WHEN AELT
	(LET ((NAMES (QF-NTH LOCALNUM (QF-CAR (QF-CDR AELT)))))
	  (COND ((NULL NAMES) NIL)
		((QF-NULL NAMES) NIL)
		((QF-NULL (QF-CDR NAMES)) (QF-CAR NAMES))
		(T NAMES)))))))

;; Given a fef and the number of a slot in the argument block,
;; return the name of that argument (or NIL if unknown).
;; First we look for an arg map, then we look for a name in the ADL.
(DEFUN LAM-DISASSEMBLE-ARG-NAME (FEF ARGNUM)
  (WHEN (= (QF-DATA-TYPE (QF-CURRENT-PACKAGE)) DTP-ARRAY-POINTER)
    (LET* ((FDI (QF-FEF-DEBUGGING-INFO FEF))
	   (AELT (QF-ASSQ (QF-SYMBOL 'COMPILER:ARG-MAP) FDI))
	   (ARGMAP (AND AELT (QF-CAR (QF-CDR AELT)))))
      (AND ARGMAP (QF-CAR (QF-NTH ARGNUM ARGMAP))))))

(DEFUN (:PROPERTY PF LAM-COLON-CMD) (IGNORE)
  (COND ((NULL LAM-OPEN-REGISTER)
	 (format t "~%NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)"))
	(T 
	 (LET ((CALL-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 3)))
	       (EXIT-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 2)))
	       (ENTRY-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 1)))
	       (FUNCTION-WORD (LAM-REGISTER-EXAMINE LAM-OPEN-REGISTER)))
	   (TERPRI) (LAM-TYPE-OUT FUNCTION-WORD 'LAM-SEXP-DESC T NIL)
	   (TERPRI) (LAM-TYPE-OUT CALL-WORD 'CALL-WORD-DESC 'ALL NIL)
	   (TERPRI) (LAM-TYPE-OUT EXIT-WORD 'EXIT-WORD-DESC 'ALL NIL)
	   (TERPRI) (LAM-TYPE-OUT ENTRY-WORD 'ENTRY-WORD-DESC 'ALL NIL)
	   (COND ((NOT (ZEROP (LDB %%LP-CLS-ADI-PRESENT CALL-WORD)))
		  (DO ((ADR (pb-regadr-sub LAM-OPEN-REGISTER 4) (pb-regadr-sub ADR 2))
		       (W1)(W2))
		      (NIL)
		    (DECLARE (FIXNUM ADR W1 W2))
		    (SETQ W1 (LAM-REGISTER-EXAMINE ADR)
			  W2 (LAM-REGISTER-EXAMINE (- ADR 1)))
		    (TERPRI)
		    (LAM-TYPE-OUT W1 'ADI-W1-DESC 'ALL NIL)
		    (TERPRI)
		    (LAM-TYPE-OUT W2 'ADI-W2-DESC 'ALL NIL)
		    (AND			;(ZEROP (LDB %%Q-FLAG-BIT W2))
		      ;; Above is used thru ucode 202, below is used after.
		      (ZEROP (LDB %%ADI-PREVIOUS-ADI-FLAG W2))
		      (RETURN NIL)))))
	   (let ((ADR (pb-regadr-add LAM-OPEN-REGISTER 1))
		 (CNT (LDB %%LP-ENS-NUM-ARGS-SUPPLIED ENTRY-WORD)))
	     (dotimes (c cnt)
	       (let ((pb-adr (pb-regadr-add adr c)))
		 (terpri)
		 (lam-print-address pb-adr)
		 (princ "   ")
		 (let ((var (lam-disassemble-arg-name function-word c)))
		   (if var (lam-q-print-toplev var) (princ " --- ")))
		 (princ "   ")
		 (lam-q-print-toplev (lam-register-examine pb-adr)))))
	   (let ((ADR (pb-regadr-add LAM-OPEN-REGISTER
			 (ldb %%lp-ens-macro-local-block-origin entry-word)))
		 (CNT (LDB %%fefhi-ms-local-block-length
			   (qf-mem-read (+ %fefhi-misc (qf-pointer function-word))))))
	     (dotimes (c cnt)
	       (let ((pb-adr (pb-regadr-add c adr)))
		 (terpri)
		 (lam-print-address pb-adr)
		 (princ "   ")
		 (let ((var (lam-disassemble-local-name function-word c)))
		   (if var (lam-q-print-toplev var) (princ " --- ")))
		 (princ "   ")
		 (lam-q-print-toplev (lam-register-examine pb-adr)))))
	)))
  (TERPRI))


(DEFUN (:PROPERTY previous-active-frame lam-colon-cmd) (ignore)
  (COND ((NULL LAM-OPEN-REGISTER)
	 (format t "~%NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)"))
	(T 
	 (LET* ((CALL-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 3)))
		(pb-adr (pb-regadr-sub lam-open-register
				       (ldb %%lp-cls-delta-to-active-block call-word))))
	   (lam-print-address pb-adr)
	   (princ "   ")
	   (lam-slash pb-adr)))))

(DEFUN (:PROPERTY previous-active-frame-chain lam-colon-cmd) (ignore)
  (COND ((NULL LAM-OPEN-REGISTER)
	 (format t "~%NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)"))
	(T 
	 (do () (())
	   (LET* ((CALL-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 3)))
		  (delta (ldb %%lp-cls-delta-to-active-block call-word)))
	     (if (zerop delta)
		 (return nil)
	       (let ((pb-adr (pb-regadr-sub lam-open-register delta)))
		 (lam-print-address pb-adr)
		 (princ "   ")
		 (lam-slash pb-adr))))))))

(DEFUN (:PROPERTY previous-open-frame lam-colon-cmd) (ignore)
  (COND ((NULL LAM-OPEN-REGISTER)
	 (format t "~%NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)"))
	(T 
	 (LET* ((CALL-WORD (LAM-REGISTER-EXAMINE (pb-regadr-sub LAM-OPEN-REGISTER 3)))
		(pb-adr (pb-regadr-sub lam-open-register
				     (ldb %%lp-cls-delta-to-open-block call-word))))
	   (lam-print-address pb-adr)
	   (princ "   ")
	   (lam-slash pb-adr)))))

(defun pb-regadr-add (regadr inc)
  (let ((tem (+ regadr inc)))
    (cond ((not (and (>= regadr rapbo) (< regadr (+ rapbo 4000))))
	   tem)
	  ((< tem (+ rapbo 4000))
	   tem)
	  (t (- tem 4000)))))

(defun pb-regadr-sub (regadr inc)
  (let ((tem (- regadr inc)))
    (cond ((not (and (>= regadr rapbo) (< regadr (+ rapbo 4000))))
	   tem)
	  ((>= tem rapbo)
	   tem)
	  (t (+ tem 4000)))))

(SETQ CALL-WORD-DESC '(
    (TYPE CALL-WORD)
    (SELECT-FIELD ATTENTION 3001 (NIL ATTENTION))
    (SELECT-FIELD SELF-MAP 2701 (NIL SELF-MAP-PROVIDED))
    (SELECT-FIELD TRAP-ON-EXIT 2601 (NIL TRAP-ON-EXIT))
    (SELECT-FIELD ADI-PRESENT 2401 (NIL ADI-PRESENT))
    (SELECT-FIELD S-DEST 2004 (D-INDS D-PDL D-RETURN D-LAST D-MICRO))
    (TYPE-FIELD DELTA-TO-OPEN-BLOCK 1010 NIL)
    (TYPE-FIELD DELTA-TO-ACTIVE-BLOCK 0010 NIL)))

(SETQ EXIT-WORD-DESC '(
    (TYPE EXIT-WORD)
    (SELECT-FIELD MICRO-STACK-SAVED 2101 (NIL MICRO-STACK-SAVED))
    (SELECT-FIELD BINDING-BLOCK-PUSHED 2001 (NIL BINDING-BLOCK-PUSHED))
    (TYPE-FIELD SAVED-PC 0017 NIL)))

(SETQ ENTRY-WORD-DESC '(
    (TYPE ENTRY-WORD)
    (SELECT-FIELD LAST-CALL-TYPE 2001 (NIL REST-ARG-PASSED))
    (SELECT-FIELD UNSAFE-REST-ARG 1701 (NIL UNSAFE-REST-ARG))
    (SELECT-FIELD ENVIRONMENT-POINTER-POINTS-HERE 1601 (NIL ENVIRONMENT-POINTER))
    (TYPE-FIELD NUM-ARGS 1006 NIL)
    (TYPE-FIELD LOC-BLOCK-ORIGIN 0010 NIL)))

;(comment 
;(SETQ ADI-W1-DESC '(
;    (TYPE ADI-W1)
;    (SELECT-FIELD FLAG-BIT 3501 (NO-FLAG-BIT-ERROR NIL))
;    (SELECT-FIELD ADI-TYPE 2403 (ERR RETURN-INFO RESTART-PC FEXPR-CALL LEXPR-CALL 
;				   BIND-STACK-LEVEL T USED-UP-RETURN-INFO))
;    (SELECT-FIELD STORING-OPT 2103 (ERR BLOCK LIST MAKE-LIST INDIRECT T T T))
;    (TYPE-FIELD NUM-VALS-EXPECTING 0006 NIL)))

;(SETQ ADI-W2-DESC '(
;    (TYPE ADI-W2)
;    (TYPE-FIELD FLAG-BIT 3501 NIL)
;    (TYPE-FIELD W2 0030 NIL)))
;)

(SETQ ADI-W1-DESC '(
    (TYPE ADI-W1)
    (SELECT-FIELD PREVIOUS-ADI-FLAG 3601 (NO-PREVIOUS-ADI PREVIOUS-ADI))
    (SELECT-FIELD ADI-TYPE 2403 (ERR RETURN-INFO RESTART-PC FEXPR-CALL LEXPR-CALL 
				   BIND-STACK-LEVEL T USED-UP-RETURN-INFO))
    (SELECT-FIELD STORING-OPT 2103 (ERR BLOCK LIST MAKE-LIST INDIRECT T T T))
    (TYPE-FIELD NUM-VALS-EXPECTING 0006 NIL)))

(SETQ ADI-W2-DESC '(
    (TYPE ADI-W2)
    (SELECT-FIELD PREVIOUS-ADI-FLAG 3601 (NO-PREVIOUS-ADI PREVIOUS-ADI))
    (TYPE-FIELD W2 0030 NIL)))

;Search physical memory (ie currently swapped in stuff) for arg.
(DEFUN (:PROPERTY PHYS-MEM-WORD-SEARCH LAM-COLON-CMD) (QUAN)
  (DECLARE (FIXNUM ADR TEM))
  (DO ((ADR 0 (1+ ADR))
       (TEM))
      ((OR (= ADR 400000) (KBD-TYI-NO-HANG)))   ;SEARCHES 128K  **CROCK**
      (COND ((= QUAN (SETQ TEM (PHYS-MEM-READ ADR)))
	     (FORMAT T "~%~S~1,8@T~S  " ADR TEM)))))

(defun phys-mem-one-bit-differs-search (adr quan
					&aux (size-of-physical-memory-in-pages 0)
					     (size-of-physical-memory 0))
  (dolist (e (send *proc* :memory-configuration-list))
    (setq size-of-physical-memory-in-pages (+ size-of-physical-memory-in-pages (car e))))
  (setq size-of-physical-memory (ash size-of-physical-memory-in-pages 8))
  (dotimes (bit-no 24.)
    (let ((trial-address (logxor adr (ash 1 bit-no))))
      (cond ((< trial-address size-of-physical-memory)
	     (cond ((= quan (phys-mem-read trial-address))
		    (format t "~%bit:~s adr:~s data:~s" bit-no trial-address quan))))))))

(proclaim '(SPECIAL CONS-FUNC-DEST-INT-CNTRL)) ;CADMAC does not get included in compilation

;:INTOFF disables hardware interrupts and sequence breaks
(DEFUN (:PROPERTY INTOFF LAM-COLON-CMD) (IGNORE)
  (write-rg-mode (dpb 0 interrupt-enable (read-rg-mode))))

(DEFUN (:PROPERTY inton lam-colon-cmd) (ignore)
  (write-rg-mode (dpb 1 interrupt-enable (read-rg-mode))))

(DEFUN (:PROPERTY tvintoff lam-colon-cmd) (ignore)
  (tv-disable-interrupts))

(DEFUN (:PROPERTY tvinton lam-colon-cmd) (ignore)
  (tv-enable-interrupts))

(DEFUN (:PROPERTY DESCRIBE LAM-COLON-CMD) (IGNORE)
  (AND LAM-LAST-VALUE-TYPED 
       (LET ((DT (QF-DATA-TYPE LAM-LAST-VALUE-TYPED)))
	 (select dt
	   (DTP-STACK-GROUP
	    (LAM-DESCRIBE-STACK-GROUP LAM-LAST-VALUE-TYPED))
	   ((DTP-CLOSURE DTP-ENTITY)
	    (LAM-DESCRIBE-CLOSURE LAM-LAST-VALUE-TYPED))
	   (DTP-FEF-POINTER
	    (LAM-DESCRIBE-FEF LAM-LAST-VALUE-TYPED))
	   (DTP-INSTANCE
	    (LAM-DESCRIBE-INSTANCE LAM-LAST-VALUE-TYPED))
	   (dtp-extended-number
	    (lam-describe-extended-number lam-last-value-typed))
	   (dtp-array-pointer
	    (lam-describe-array lam-last-value-typed))
	   (dtp-header
	    (format t "~&this is a header, not a pointer"))
	   (otherwise
	    (format t "~&can't describe type ~o" dt))
	       ))))

(defun lam-describe-array (p)
  (let* ((p-p  (qf-pointer p))
	 (header (lam-mem-read p-p))
	 (header-dt (ldb %%q-data-type header))
	 (type-code (ldb %%array-type-field header))
	 (leader-p (ldb %%array-leader-bit header))
	 (displaced-p (ldb %%array-displaced-bit header))
	 (number-dimensions (ldb %%array-number-dimensions header))
	 (long-length-flag (ldb %%array-long-length-flag header))
	 (named-structure-flag (ldb %%array-named-structure-flag header))
	 (index-length (ldb %%array-index-length-if-short header))
	 (data-origin (+ (qf-pointer p)
			 long-length-flag
			 number-dimensions)))
    (cond ((not (= header-dt dtp-array-header))
	   (format t "~%Header data type is ~s (~s) instead of dtp-array-header!"
		   (nth header-dt q-data-types)
		   header-dt)))
    (if (not (zerop long-length-flag))
	(setq index-length (qf-pointer (lam-mem-read (1+ p-p)))))
    (cond ((not (zerop displaced-p))
	   (format t "~%A displaced array"))
	  ((eq (nth type-code array-types) 'art-string)
	   (lam-q-print-toplev p))
	  (t (Format t "~%An array of type ~s, ~D dimensions, index length ~s"
		     (nth type-code array-types)
		     number-dimensions
		     index-length)))
    (cond ((not (zerop leader-p))
	   (format t "~% Has leader of length ~s"
		   (qf-pointer (lam-mem-read (1- p-p))))))
    (cond ((not (zerop named-structure-flag))
	   (LET ((NSS NIL)
		 defstruct-type)
	     (COND ((NOT (ZEROP (MASK-FIELD-FROM-FIXNUM
				  %%ARRAY-LEADER-BIT HEADER)))
		    (SETQ NSS (QF-ARRAY-LEADER p 1)
			  defstruct-type 'array-leader)
		    )
		   (T (SETQ NSS (QF-AR-1 p 0)
			    defstruct-type 'array)
		      ))
	     (PRINC " NAMED-STRUCTURE-SYMBOL #<")
	     (LAM-Q-PRINT-TOPLEV NSS)
	     (PRINC ">")
	     (let ((defstruct-description (qf-get nss (qf-symbol 'si:defstruct-description))))
	       (do ((dl (qf-nth 3 defstruct-description) (qf-cdr dl))
		    (islot)
		    (i 0 (1+ i)))
		   ((qf-null dl))
		 (LAM-Q-PRINT-TOPLEV  (qf-car (QF-CAR dl)))
		 (FORMAT T "	:~27T ")
		 (SETQ ISLOT
		       (selectq defstruct-type
			 (array (LAM-P-CONTENTS-OFFSET p (1+ I)))
			 (array-leader (qf-array-leader p (if (zerop i) 0
							    (1+ i))))))
		 (COND ((= (QF-DATA-TYPE ISLOT) DTP-NULL)
			(FORMAT T "unbound~%"))
		       (T (LAM-Q-PRINT-TOPLEV ISLOT)
			  (FORMAT T "~%")))		 
		 )))
	   ))

    ))

(defun lam-describe-extended-number (p)
  (format t "~&")
  (lam-q-print-toplev p)
  (format t "   ")
  (select (lam-p-ldb-offset %%header-type-field p 0)
    (%header-type-bignum
     (lam-describe-bignum p))
    (%header-type-flonum
     (format t "a flonum, w0 ~s, w1 ~s"
	     (qf-mem-read p)
	     (qf-mem-read (1+ p))))
    (%header-type-complex
     (format t "a complex"))
    (%header-type-rational
     (format t "a rational"))
    (t
     (format t "but the header type is ~o, not a number"
	     (lam-p-ldb-offset %%header-type-field p 0)))))

(defun lam-describe-bignum (p)
  (let ((len (lam-p-ldb-offset 0022 p 0))
	(sign (lam-p-ldb-offset 2201 p 0))
	(val 0))
    (format t "a bignum length: ~d. ~[positive~;negative~]" len sign)
    (dotimes (i len)
      (setq val (+ (ash val 31.) (qf-mem-read (+ p i 1)))))
    (format t " value = ~o ~:*~d. ~:*#x~16r ~&" val)))

(DEFUN LAM-DESCRIBE-INSTANCE (INST &AUX FLAVOR-DEFSTRUCT FLAVOR-NAME)
  (FORMAT T "An instance of flavor ")
  (SETQ FLAVOR-DEFSTRUCT (LAM-P-CONTENTS-AS-LOCATIVE-OFFSET INST 0)
	FLAVOR-NAME (LAM-P-CONTENTS-OFFSET FLAVOR-DEFSTRUCT %INSTANCE-DESCRIPTOR-TYPENAME))
  (LAM-Q-PRINT-TOPLEV FLAVOR-NAME)
  (FORMAT T " has instance variable values:~%")
  (DO ((IVARS (LAM-REF-DEFSTRUCT 'SI:FLAVOR-ALL-INSTANCE-VARIABLES
				FLAVOR-DEFSTRUCT
				'AREF)
	      (QF-CDR IVARS))
       (ISLOT)
       (I 1 (1+ I)))
      ((QF-NULL IVARS))
    (LAM-Q-PRINT-TOPLEV  (QF-CAR IVARS))
    (FORMAT T "	:(~s)~27T " I)
    (SETQ ISLOT (LAM-P-CONTENTS-OFFSET INST I))
    (COND ((= (QF-DATA-TYPE ISLOT) DTP-NULL)
	   (FORMAT T "unbound~%"))
	  (T (LAM-Q-PRINT-TOPLEV ISLOT)
	     (FORMAT T "~%")))))

(DEFUN LAM-REFERENCE-INSTANCE (INSTANCE INSTANCE-VARIABLE-NAME
			       &AUX FLAVOR-DEFSTRUCT FLAVOR-NAME
			            INSTANCE-VARIABLE-SYMBOL-POINTER TEM)
  (SETQ INSTANCE-VARIABLE-SYMBOL-POINTER  (QF-SYMBOL INSTANCE-VARIABLE-NAME))
  (SETQ FLAVOR-DEFSTRUCT (LAM-P-CONTENTS-AS-LOCATIVE-OFFSET INSTANCE 0)
	FLAVOR-NAME (LAM-P-CONTENTS-OFFSET FLAVOR-DEFSTRUCT %INSTANCE-DESCRIPTOR-TYPENAME))
  (DO ((IVARS (LAM-REF-DEFSTRUCT 'SI:FLAVOR-ALL-INSTANCE-VARIABLES
				FLAVOR-DEFSTRUCT
				'AREF)
	      (QF-CDR IVARS))
       (I 1 (1+ I)))
      ((QF-NULL IVARS)
       (FERROR "FAILED TO FIND INSTANCE VARIABLE"))
    (SETQ TEM (QF-CAR IVARS))
;    (FORMAT T "~%COMPARING ~S AND ~S " TEM INSTANCE-VARIABLE-SYMBOL-POINTER)
;    (LAM-Q-PRINT-TOPLEV TEM)
;    (LAM-Q-PRINT-TOPLEV INSTANCE-VARIABLE-SYMBOL-POINTER)
    (COND ((= TEM INSTANCE-VARIABLE-SYMBOL-POINTER)
	   (RETURN (LAM-P-CONTENTS-OFFSET INSTANCE I))))))

(DEFUN LAM-DESCRIBE-STACK-GROUP (SG)
  (PROG (PNTR)
	(SETQ PNTR (QF-POINTER SG))
	(FORMAT T "~%Stack group: " )
	(LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (- PNTR 2 SG-NAME)))
	(LET ((STATE (LAM-MEM-READ (- PNTR 2 SG-STATE))))
	   (COND ((NOT (ZEROP (LDB %%SG-ST-IN-SWAPPED-STATE STATE)))
		  (FORMAT T "~% Variables currently swapped out")))
	   (COND ((NOT (ZEROP (LDB %%SG-ST-FOOTHOLD-EXECUTING STATE)))
		  (FORMAT T "~% Foothold currently executing")))
	   (COND ((NOT (ZEROP (LDB %%SG-ST-PROCESSING-ERROR STATE)))
		  (FORMAT T "~% Currently processing an error")))
	   (FORMAT T ", State ~S" (NTH (LDB %%SG-ST-CURRENT-STATE STATE) SG-STATES)))
	(DO ((L STACK-GROUP-HEAD-LEADER-QS (CDR L))
	     (A (- PNTR 2) (1- A))
	     (WD))
	    ((NULL L))
	  (FORMAT T "~%~O~10T~A:~30T" A (CAR L))
	  (SETQ WD (LAM-MEM-READ A))
	  (LAM-TYPE-OUT WD LAM-Q-DESC NIL NIL)
	  (TYO #\TAB)
	  (ERRSET (LAM-Q-PRINT-TOPLEV WD)))
	(TERPRI)))

(DEFUN LAM-DESCRIBE-CLOSURE (CLOS)
 ;  (cond ((= (qf-data-type clos) dtp-stack-closure)
 ;	 (format t "~% Stack closure pointers to ")
 ;	 (lam-print-area-of-pointer clos)))
  (FORMAT T "~%CLOSED-FUNCTION ")
  (LET ((FUNCT (QF-CAR CLOS)))
    (LAM-Q-PRINT-TOPLEV funct)
    (cond ((qf-null (qf-cdr (qf-cdr clos)))
	   (cond ((= (qf-data-type funct) dtp-list)
		  (format t "~%Interpreter lexical closure")
		  )
		 (t
		  (format t "~%Compiler lexical closure")
		  )))
	  (t
	   (format t "~%Dynamic closure")
	   (DO ((L (QF-CDR CLOS) (QF-CDR (QF-CDR L))))
	       ((LAM-Q-NULL L))
	     (FORMAT T "~&~o: SYM: " (qf-pointer l))
	     (LAM-Q-PRINT-TOPLEV (1- (QF-SMASH-DATA-TYPE (QF-CAR L) DTP-SYMBOL)))
	     (FORMAT T " VALUE:")
	     (LAM-Q-PRINT-TOPLEV (QF-CAR (QF-CAR (QF-CDR L)))))))))

(DEFUN LAM-P-LDB-OFFSET (PPSS PNTR OFF)
  (LOGLDB PPSS (QF-MEM-READ (+ PNTR OFF))))

(DEFUN LAM-P-CONTENTS-OFFSET (PNTR OFF)
       (LOGLDB %%QF-TYPED-POINTER (LAM-MEM-READ (+ PNTR OFF))))

(DEFUN LAM-P-CONTENTS-AS-LOCATIVE-OFFSET (PNTR OFF)
  (DO ((CONTS (LAM-MEM-READ (+ PNTR OFF)) (LAM-MEM-READ CONTS)))
      (())   ;comment in TYPEP wrong?
    (RETURN (QF-SMASH-DATA-TYPE CONTS DTP-LOCATIVE))))
    
;COMP is assumed to be a defstruct referencer (NAMED-SUBST) in the remote machine.
;return that component of the structure on the debugged machine.
(DEFUN LAM-REF-DEFSTRUCT (COMP DEFS TYPE)
  (QF-TYPED-POINTER (QF-MEM-READ (+ DEFS (1+ (LAM-GET-DEFSTRUCT-INDEX COMP TYPE))))))

(DEFUN LAM-GET-DEFSTRUCT-INDEX (COMP &OPTIONAL TYPE)
  (if (not (memq type '(aref array-leader))) (ferror "this may not work"))
  
  (LET ((AT (QF-SYMBOL COMP)))
    (IF (= AT -1)
	(FERROR "UNABLE TO INTERN SYMBOL ~S IN OTHER MACHINE" COMP)
      (LET ((FUNCT (QF-FUNCTION-CELL-CONTENTS AT)))
	;; If the function is compiled, ask for its interpreted definition.
	;; A DEFSUBST is always supposed to have one.
	(IF (= (QF-DATA-TYPE FUNCT) DTP-FEF-POINTER)
	    (LET ((IPC (LAM-P-LDB-OFFSET %%FEFH-PC FUNCT %FEFHI-IPC))
		  (FLAG (LAM-P-LDB-OFFSET %%FEFHI-MS-DEBUG-INFO-PRESENT FUNCT %FEFHI-MISC)))
	      ;; If FLAG is 1, the fef has debug info.  Search it for the interpreted defn.
	      ;; (SETQ FUNCT (CADR (ASSQ 'SYSTEM:INTERPRETED-DEFINITION
	      ;;			 (DEBUGGING-INFO FUNCT))))
	      (IF (= FLAG 1)
		  (LET ((DEBUG-INFO (LAM-P-CONTENTS-OFFSET FUNCT (1- (// IPC 2))))
			(SYMBOL (QF-SYMBOL1 'INTERPRETED-DEFINITION
					    (QF-FIND-PACKAGE 'SYSTEM))))
		    (DO ((DEB-INF DEBUG-INFO (QF-CDR DEB-INF)))
			(( (QF-DATA-TYPE DEB-INF) DTP-LIST))
		      (IF (= (QF-CAR (QF-CAR DEB-INF))
			     SYMBOL)
			  (RETURN (SETQ FUNCT (QF-CAR (QF-CDR (QF-CAR DEB-INF)))))))))))
	(COND ((= (QF-DATA-TYPE FUNCT) DTP-LIST)
;funct might be:
;
;  for a regular defstruct
;  (named-subst (name-and-documentation) (arglist) (declare) nil (aref foo 10))
;  for a flavor
;  (named-subst (name-and-documentation) (arglist) (declare) (aref foo 10))
	       (cond ((not  (QF-SAMEPNAMEP 'NAMED-SUBST (QF-CAR FUNCT)))
		      nil)
		     ((and type (qf-samepnamep
				  type
				  (QF-CAR (QF-CAR
					    (qf-cdr (QF-CDR (QF-CDR (QF-CDR FUNCT))))))))
		      (qf-pointer (qf-car
				    (qf-cdr
				      (qf-cdr
					(qf-car
					  (qf-cdr (qf-cdr (qf-cdr (qf-cdr funct))))))))))
		     (t (qf-pointer (qf-car
				      (qf-cdr
					(qf-cdr
					  (qf-car
					    (qf-cdr (qf-cdr
						      (qf-cdr (qf-cdr (qf-cdr funct)))))))))))))
	      (t
	       nil))))))
    
(DEFUN LAM-DESCRIBE-FEF (FEF &AUX HEADER HEADER-TYPE NAME FAST-ARG SV MISC LENGTH DBI
			 NO-ADL-EXISTS FAST-ARG-ACTIVE)
  (SETQ HEADER (LAM-P-LDB-OFFSET %%HEADER-REST-FIELD FEF %FEFHI-IPC))
  (SETQ HEADER-TYPE (LAM-P-LDB-OFFSET %%HEADER-TYPE-FIELD FEF %FEFHI-IPC))
  (SETQ LENGTH (LAM-P-CONTENTS-OFFSET FEF %FEFHI-STORAGE-LENGTH))
  (SETQ NAME (LAM-P-CONTENTS-OFFSET FEF %FEFHI-FCTN-NAME))
  (SETQ FAST-ARG (LAM-P-CONTENTS-OFFSET FEF %FEFHI-FAST-ARG-OPT))
  (SETQ SV (LAM-P-CONTENTS-OFFSET FEF %FEFHI-SV-BITMAP))
  (SETQ MISC (LAM-P-CONTENTS-OFFSET FEF %FEFHI-MISC))
  (SETQ FAST-ARG-ACTIVE 0)
  (FORMAT T "~%FEF for function ") (LAM-Q-PRINT-TOPLEV NAME) (TERPRI)
  (FORMAT T "Initial relative PC: ~S halfwords.~%" (LDB %%FEFH-PC HEADER))
  (cond ((= header-type %header-type-fef)
	 (SETQ NO-ADL-EXISTS (LDB %%FEFH-NO-ADL HEADER)
	       FAST-ARG-ACTIVE (LDB %%FEFH-FAST-ARG HEADER))
	 (COND ((NOT (ZEROP (LDB %%FEFH-GET-SELF-MAPPING-TABLE HEADER)))
		(FORMAT T "This is a method of flavor ")
		(LAM-Q-PRINT-TOPLEV
		  (LAM-P-CONTENTS-OFFSET FEF (1- (LAM-P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG
								   FEF %FEFHI-MISC))))))
; -- Special variables
	 (COND ((ZEROP (LDB %%FEFH-SV-BIND HEADER))
		(PRINC "There are no special variables present."))
	       (T (PRINC "There are special variables, ")
		  (TERPRI)
		  (COND ((ZEROP (LDB %%FEFHI-SVM-ACTIVE SV))
			 (PRINC "but the S-V bit map is not active. "))
			(T (FORMAT T "and the S-V bit map is active and contains: ~O"
				   (LDB %%FEFHI-SVM-BITS SV))))))
	 (TERPRI))
	((= header-type %HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS)
	 (setq no-adl-exists (LAM-p-ldb-offset %%fefsl-no-adl fef %fefhi-storage-length))
	 (FORMAT T "The fast-fef option FIXED-ARGS-NO-LOCALS is selected.~%")
	 (FORMAT T "It says there are ~s args.~%" (ldb %%fefh-args-for-fanl header)))
	((= header-type %HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS)
	 (setq no-adl-exists (LAM-p-ldb-offset %%fefsl-no-adl fef %fefhi-storage-length))
	 (FORMAT T "The fast-fef option VAR-ARGS-NO-LOCALS is selected.~%")
	 (format t "It says there are between ~s and ~s args.~%"
		 (LAM-p-ldb-offset %%fefh-min-args-for-vanl fef %fefhi-ipc)  ;cdr-code
		 (ldb %%fefh-max-args-for-vanl header)))
	((= header-type %HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS)
	 (setq no-adl-exists (LAM-p-ldb-offset %%fefsl-no-adl fef %fefhi-storage-length))
	 (format t "The fast-fef option FIXED-ARGS-WITH-LOCALS is selected.~%")
	 (format t "It says there are ~s args and ~s locals.~%"
		 (LAM-p-ldb-offset %%fefh-args-for-fawl fef %fefhi-ipc)	   ;cdr-code
		 (ldb %%fefh-locals-for-fawl header)))
	((= header-type %HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS)
	 (setq no-adl-exists (LAM-p-ldb-offset %%fefsl-no-adl fef %fefhi-storage-length))
	 (format t "The fast-fef option VAR-ARGS-WITH-LOCALS is selected.~%")
	 (format t "It says there are between ~s and ~s args and ~s locals.~%"
		 (LAM-p-ldb-offset %%fefh-min-args-for-vawl fef %fefhi-ipc)  ;cdr-code
		 (ldb %%fefh-max-args-for-vawl header)
		 (ldb %%fefh-locals-for-vawl header)))
	(t (format t "The header type field (~s) is not a known code.~%"
		   header-type)
	   (setq no-adl-exists (LAM-p-ldb-offset %%fefsl-no-adl fef %fefhi-storage-length))))
  
; -- Print out the fast arg option
  (FORMAT T "The Fast Argument Option is ~A"
	  (IF (ZEROP FAST-ARG-ACTIVE)
	      "not active, but here it is anyway:"
	      "active:"))
  (SI:DESCRIBE-NUMERIC-DESCRIPTOR-WORD FAST-ARG)
; -- Randomness.
  (FORMAT T "~%The length of the local block is ~S~%"
	  (LDB %%FEFHI-MS-LOCAL-BLOCK-LENGTH MISC))
  (FORMAT T "The total storage length of the FEF is ~S~%"
	  (QF-POINTER LENGTH))
; -- ADL.
  (COND ((ZEROP NO-ADL-EXISTS)
	 (FORMAT T "There is an ADL:  It is ~S long, and starts at ~S"
		 (LDB %%FEFHI-MS-BIND-DESC-LENGTH MISC)
			   (LDB %%FEFHI-MS-ARG-DESC-ORG MISC))
	 (LAM-DESCRIBE-ADL (LAM-GET-MACRO-ARG-DESC-POINTER FEF))
	 )
	(T (PRINC "There is no ADL.")))
  (TERPRI)
  (COND ((SETQ DBI (FUNCTION-DEBUGGING-INFO FEF))
	 (FORMAT T "Debugging info:~%")
	 (do ((dbp dbi (qf-cdr dbp))
	      (db))
	     ((qf-null dbp))
	   (setq db (qf-car dbp))
	   (lam-q-print-toplev db)
	   (format t "~%"))))
  )
   
(defun function-debugging-info (funct)
  (LET ((IPC (LAM-P-LDB-OFFSET %%FEFH-PC FUNCT %FEFHI-IPC))
	(FLAG (LAM-P-LDB-OFFSET %%FEFHI-MS-DEBUG-INFO-PRESENT FUNCT %FEFHI-MISC)))
    (IF (= FLAG 1)
	(LAM-P-CONTENTS-OFFSET FUNCT (1- (// IPC 2))))))

(DEFUN LAM-GET-MACRO-ARG-DESC-POINTER (FEF-POINTER &AUX ORIGIN)
   (COND ((= 0 (SETQ ORIGIN
		     (LAM-P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG FEF-POINTER %FEFHI-MISC)))
	  (LAM-MAKE-POINTER DTP-SYMBOL 0))
	 (T (LAM-MAKE-POINTER-OFFSET DTP-LIST FEF-POINTER ORIGIN))))


(DEFUN LAM-MAKE-POINTER (DT PNTR)
       (DPB DT %%QF-DATA-TYPE PNTR))

(DEFUN LAM-MAKE-POINTER-OFFSET (DT PNTR OFF)
       (DPB DT %%QF-DATA-TYPE (+ PNTR OFF)))

(DEFUN LAM-DESCRIBE-ADL (ADL)
  (PROG (OPT-Q INIT-OPTION)
     L
	(COND ((LAM-Q-NULL ADL) (RETURN NIL)))
    	(SETQ OPT-Q (QF-CAR ADL) ADL (QF-CDR ADL))
	(TERPRI)
	(COND ((NOT (ZEROP (LOGAND OPT-Q %FEF-NAME-PRESENT)))
	       (PRINC "NAME ")
	       (LAM-Q-PRINT-TOPLEV (QF-CAR ADL))
	       (SETQ ADL (QF-CDR ADL))))
	(PRIN1-THEN-SPACE (NTH (LDB %%FEF-SPECIALNESS OPT-Q)
			       FEF-SPECIALNESS))
	(PRIN1-THEN-SPACE (NTH (LDB %%FEF-DES-DT OPT-Q)
			       FEF-DES-DT))
	(PRIN1-THEN-SPACE (NTH (LDB %%FEF-QUOTE-STATUS OPT-Q)
			       FEF-QUOTE-STATUS))
	(PRIN1-THEN-SPACE (NTH (LDB %%FEF-ARG-SYNTAX OPT-Q)
			       FEF-ARG-SYNTAX))
	(PRIN1-THEN-SPACE (SETQ INIT-OPTION (NTH (LDB %%FEF-INIT-OPTION OPT-Q)
						 FEF-INIT-OPTION)))
	(COND ((MEMQ INIT-OPTION '(FEF-INI-PNTR FEF-INI-C-PNTR 
				   FEF-INI-OPT-SA FEF-INI-EFF-ADR))
	       (PRINC "ARG ")
	       (LAM-Q-PRINT-TOPLEV (QF-CAR ADL))
	       (SETQ ADL (QF-CDR ADL))))
	(GO L)))


(DEFUN (:PROPERTY describe-lexical-environment LAM-COLON-CMD) (ARG)
   (SETQ ARG (OR ARG LAM-LAST-VALUE-TYPED))
   (do ((env arg (qf-cdr env))
	(count 0 (1+ count)))
       ((qf-null env))
     (let ((fef (qf-mem-read (- env 2))))
       (format t "~%Frame ~d, base address ~s, resident in " count (qf-pointer env))
       (lam-print-area-of-pointer env)
       (format t "~%fef [~s]=" (qf-pointer (- env 2)))
       (lam-q-print-toplev fef)
       (format t "~% frame pointer [~s]=" (qf-pointer (- env 1)))
       (let ((fp (qf-mem-read (- env 1))))
	 (lam-q-print-toplev fp)
	 (let ((svp (qf-mem-read env)))
	   (format t "~% stack-closure-vector-pointer[~s]= [~s]"
		   (qf-pointer env) (qf-pointer svp))
	   (lam-q-print-toplev svp)
	   (format t " in ")
	   (lam-print-area-of-pointer svp)
	   (cond ((not (= (qf-data-type svp) dtp-symbol))  ;dont do this if its T or NIL
		  (let* ((main-frame-pointer (qf-mem-read (1- svp)))
			 (main-frame-fef (qf-mem-read main-frame-pointer)))
		    (format t "~% Main frame fef [~s] is " main-frame-pointer)
		    (lam-q-print-toplev main-frame-fef))))
	   (let* ((fefhi-misc-wd (qf-mem-read (+ fef %fefhi-misc)))
		  (local-block-length (ldb %%fefhi-ms-local-block-length fefhi-misc-wd)))
	     (format t "~%local-block-length for this fef ~D" local-block-length)))))
     (format t "~%********")
     ))

(DEFUN (:PROPERTY FLAGS LAM-COLON-CMD) (QUAN)
  (LAM-TYPE-OUT (OR QUAN (LAM-SYMBOLIC-EXAMINE-REGISTER 'M-FLAGS)) 'M-FLAGS-DESC 'ALL NIL))

(SETQ M-FLAGS-DESC '(
    (TYPE M-FLAGS)
    (TYPE-FIELD M-QBFFL 0001 NIL)
    (SELECT-FIELD CAR-SYMBOL-MODE 0102 (ERROR NIL->NIL NIL ERROR))
    (SELECT-FIELD CAR-NUMBER-MODE 0302 (ERROR NIL ERROR ERROR))
    (SELECT-FIELD CDR-SYMBOL-MODE 0502 (ERROR NIL->NIL NIL PLIST))
    (SELECT-FIELD CDR-NUMBER-MODE 0702 (ERROR NIL ERROR ERROR))
    (SELECT-FIELD DONT-SWAP-IN 1101 (NIL DONT-SWAP-IN))
    (TYPE-FIELD TRAP-ENABLE 1201 NIL)
    (SELECT-FIELD MAR-MODE 1302 (NIL READ WRITE READ-AND-WRITE))
    (SELECT-FIELD PGF-WRITE 1501 (NIL PGF-WRITE))
    (SELECT-FIELD INTERRUPT 1601 (NIL INTERRUPT))
    (SELECT-FIELD SCAVENGE 1701 (NIL SCAVENGE))
    (SELECT-FIELD TRANSPORT 2001 (NIL TRANSPORT))
    (SELECT-FIELD STACK-GROUP-SWITCH 2101 (NIL STACK-GROUP-SWITCH))
    (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK))
    (SELECT-FIELD METER-STACK-GROUP-ENABLE 2301 (NIL METER-STACK-GROUP-ENABLE))
    (SELECT-FIELD TRAP-ON-CALLS 2401 (NIL TRAP-ON-CALLS))))

(DEFUN (:PROPERTY DESCRIBE-REGION-BITS LAM-COLON-CMD) (QUAN)
  (LAM-TYPE-OUT (OR QUAN LAM-LAST-VALUE-TYPED) 'REGION-BITS-DESC 'ALL NIL))

(DEFCONST REGION-BITS-DESC '(
    (TYPE REGION-BITS)
    (SELECT-FIELD %%PHT2-MAP-ACCESS-CODE SI:%%PHT2-MAP-ACCESS-CODE
		  (NO-ACCESS WRITE-ONLY! READ-ONLY READ-WRITE))
    (SELECT-FIELD  %%PHT2-MAP-STATUS-CODE SI:%%PHT2-MAP-STATUS-CODE
		   (NOT-VALID META-ONLY READ-ONLY RWF RW PDL-BUFFER MAR UNUSED))
    (TYPE-FIELD %%REGION-OLDSPACE-META-BIT SI:%%REGION-OLDSPACE-META-BIT NIL)
    (TYPE-FIELD %%REGION-EXTRA-PDL-META-BIT SI:%%REGION-EXTRA-PDL-META-BIT NIL)
    (SELECT-FIELD %%REGION-REPRESENTATION-TYPE SI:%%REGION-REPRESENTATION-TYPE
		  (LIST STRUCTURE 2--UNUSED 3--UNUSED))
    (SELECT-FIELD %%REGION-SPACE-TYPE SI:%%REGION-SPACE-TYPE
		  (FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6 STATIC FIXED EXTRA-PDL COPY
			15--UNUSED 16--UNUSED 17--UNUSED))
    (TYPE-FIELD %%REGION-SCAVENGE-ENABLE SI:%%REGION-SCAVENGE-ENABLE NIL)
    (TYPE-FIELD %%REGION-SWAPIN-QUANTUM SI:%%REGION-SWAPIN-QUANTUM NIL)
))

(proclaim '(special lam-ilong-range lam-ilong-set lam-ilong-list lam-ilong-high-half))

(defun ilong-initialize-search ()
  (setq lam-ilong-range '(0 30000))
  (setq lam-ilong-set nil)
  (setq lam-ilong-list nil)
  (setq lam-ilong-high-half t))

(defun set-ilong-if-funct-dest ()
  (if lam-ilong-set (ilong-clear))
  (setq lam-ilong-list nil)
  (let ((last (+ (car lam-ilong-range) (cadr lam-ilong-range))))
    (do ((adr (car lam-ilong-range) (1+ adr))
	 (ilong-low (ash (dpb 1 lam-ir-ilong 0) -40))
	 wd)
	((>= adr last)
	  t)
      (write-pc-fast adr)
      (setq wd (read-low-cram))
      (cond ((and (zerop (ldb 3701 wd))	;inst has destination
		  (not (zerop (ldb lam-ir-func-dest wd))))
	     (write-high-cram (logior ilong-low (read-high-cram))))
	    ))))


(defun ilong-setup nil
  (if lam-ilong-set (ilong-clear))
  (setq lam-ilong-list nil)
  (let ((last (+ (car lam-ilong-range) (cadr lam-ilong-range))))
    (do ((adr (car lam-ilong-range) (1+ adr))
	 wd
	 (ilong (dpb 1 lam-ir-ilong 0)))
	((>= adr last)
	  t)
      (cond ((zerop (logand ilong (setq wd (READ-CRAM adr))))
	     (WRITE-CRAM adr (logior ilong wd)))
	    (t (push adr lam-ilong-list)))))
  (setq lam-ilong-set t))

(defun ilong-clear nil
  (let ((last (+ (car lam-ilong-range) (cadr lam-ilong-range))))
    (do ((adr (car lam-ilong-range) (1+ adr))
	 (ilong-mask (logxor -1 (dpb 1 lam-ir-ilong 0))))
	((>= adr last))
      (cond ((memq adr lam-ilong-list))
	    (t (WRITE-CRAM adr (logand ilong-mask (READ-CRAM adr)))))))
  (setq lam-ilong-set nil))

;if last trial won, subdivide interval
;if lost,try other half of interval.
(defun ilong-trial (win)
  (if lam-ilong-set (ilong-clear))
  (cond (win (setq lam-ilong-range (list (car lam-ilong-range)
					(// (cadr lam-ilong-range) 2)))
	     (setq lam-ilong-high-half nil))
	(lam-ilong-high-half
	 (format t "~%lost on both halves of range ~s ~s"
		 (- (car lam-ilong-range) (cadr lam-ilong-range))
		 (+ (car lam-ilong-range) (cadr lam-ilong-range)))
	 (break "foo"))
	(t   (setq lam-ilong-range (list (+ (car lam-ilong-range) (cadr lam-ilong-range))
					(cadr lam-ilong-range)))
	     (setq lam-ilong-high-half t)))
  (format t "~% range now ~s" lam-ilong-range)
  (ilong-setup))


(DEFUN LOGLDB (PPSS WORD)
  (COND ((>= (LOGAND PPSS 77) 30)
	 (DPB (LDB (+ PPSS 2700 -27) WORD)
	      2727
	      (LDB (+ (LOGAND PPSS 7700) 27) WORD)))
	(T (LDB PPSS WORD))))

(DEFUN LOGDPB (BYTE PPSS WORD)
  (COND ((= PPSS 0030) (LOGIOR (BOOLE 2 WORD 77777777) (LOGAND BYTE 77777777)))
	(T (DPB BYTE PPSS WORD))))

(DEFUN MASK-FIELD-FROM-FIXNUM (PPSS WORD)
   (LOGAND WORD (DPB -1 PPSS 0)))

;assumes DEBUG-UINST file loaded.
(DEFCONST LAM-INITIAL-SYMS
	  '((RESET .  RARS)
	    (VMA . RAVMA)
	    (MD . RAMD)
	    (RAIDR . RARDRO)
	    (OPC . RAOPCO)
	    (/.IR . RAIR)
	    (IR . RASIR)
	    (MFO . RAMFO)
	    (mcr . ramcr)
	    (STATC . RASTAT)
	    (STATC-AUX . RASTAT-AUX)
	    (FDEST . RAFDO)
	    (FSRC . RAFSO)
	    (PC . RAPC)
	    (USP . RAUSP)
	    (Q . RAQ)
	    (DC . RADC) 
	    (PP . RAPP)
	    (PI . RAPI) 
	    (LC . RALC)
	    (MACRO-IR . RAMIR)
;FUNCTIONAL SOURCE SYMS FOR TYPOUT
	    (FS-DC . (FS-REGADR COM-M-SRC-DISP-CONST))
	    (FS-US . (FS-REGADR COM-M-SRC-MICRO-STACK))
	    (FS-PP . (FS-REGADR COM-M-SRC-PP))
	    (FS-PI . (FS-REGADR COM-M-SRC-PI))
	    (FS-C-PI . (FS-REGADR COM-M-SRC-C-PI))
	    (FS-C-PP . (FS-REGADR COM-M-SRC-C-PP))
	    (FS-C-PP-POP . (FS-REGADR COM-M-SRC-C-PP-POP))
	    (FS-Q . (FS-REGADR COM-M-SRC-Q))
	    (FS-VMA . (FS-REGADR COM-M-SRC-VMA))
	    (FS-L1-MAP . (FS-REGADR COM-M-SRC-L1-MAP))
	    (FS-L2-MAP-CONTROL . (FS-REGADR COM-M-SRC-L2-MAP-CONTROL))
	    (FS-L2-MAP-PHYSICAL-PAGE . (FS-REGADR COM-M-SRC-L2-MAP-PHYSICAL-PAGE))
	    (FS-MD . (FS-REGADR COM-M-SRC-MD))
	    (FS-LC . (FS-REGADR COM-M-SRC-LC))
	    (FS-US-POP . (FS-REGADR COM-M-SRC-MICRO-STACK-POP))
;FUNCTIONAL DESTINATIONS FOR TYPEOUT
	    (FD-LC . (FD-REGADR COM-FUNC-DEST-LC))
	    (FD-INT-CTL . (FD-REGADR COM-FUNC-DEST-INT-CONTROL))
	    (FD-C-PP . (FD-REGADR COM-FUNC-DEST-C-PP))
	    (FD-C-PP-PUSH . (FD-REGADR COM-FUNC-DEST-C-PP-PUSH))
	    (FD-C-PI . (FD-REGADR COM-FUNC-DEST-C-PI))
	    (FD-PI . (FD-REGADR COM-FUNC-DEST-PI))
	    (FD-PP . (FD-REGADR COM-FUNC-DEST-PP))
	    (FD-US-PUSH . (FD-REGADR COM-FUNC-DEST-MICRO-STACK-PUSH))
	    (FD-OA-LOW . (FD-REGADR COM-FUNC-DEST-IMOD-LOW))
	    (FD-OA-HIGH . (FD-REGADR COM-FUNC-DEST-IMOD-HIGH))
	    (FD-VMA . (FD-REGADR COM-FUNC-DEST-VMA))
	    (FD-VMA-RD . (FD-REGADR COM-FUNC-DEST-VMA-START-READ))
	    (FD-VMA-WRT . (FD-REGADR COM-FUNC-DEST-VMA-START-WRITE))
	    (FD-MD . (FD-REGADR COM-FUNC-DEST-MD))
	    (FD-MD-RD . (FD-REGADR COM-FUNC-DEST-MD-START-READ))
	    (FD-MD-WRT . (FD-REGADR COM-FUNC-DEST-MD-START-WRITE))
	    ))


;;; Symbol table management.

(DEFUN LAM-RECORD-SYMBOL-TABLE (FILENAME)
  (let ((old (assq filename lam-symbol-tables-loaded)))
    (when old
      (setq lam-symbol-tables-loaded (delq old lam-symbol-tables-loaded))))
  (SETQ LAM-SYMBOL-TABLES-LOADED
	(CONS (LIST FILENAME LAM-SYMBOLS-SIZE LAM-SYMBOLS-NAME LAM-SYMBOLS-VALUE)
	      LAM-SYMBOL-TABLES-LOADED)))

;Select previously loaded symbols.  Return nil if none for file.
(DEFUN LAM-SELECT-SYMBOL-TABLE (FILENAME)
  (LET ((TEM (cond ((numberp filename)
		    (dolist (f lam-symbol-tables-loaded
			       (ferror "no symbol table for version ~d." filename))
		      (cond ((and (not (null (car f)))
				  (string-equal "ulambda"
						(send-if-handles (car f) :name))
				  (string-equal (cond ((eq current-processor-type :lambda) "lmc-sym")
						      ((eq current-processor-type :explorer) "emc-sym"))
						(send-if-handles (car f) :type))
				  (eq filename (send-if-handles (car f) :version)))
			     (return f)))))
		   (t
		    (ASSQ FILENAME LAM-SYMBOL-TABLES-LOADED)))))
    (COND (TEM (SETQ LAM-FILE-SYMBOLS-LOADED-FROM (CAR TEM)
		     LAM-SYMBOLS-SIZE (CADR TEM)
		     LAM-SYMBOLS-NAME (CADDR TEM)
		     LAM-SYMBOLS-VALUE (CADDDR TEM))
	       T)))
  )

(defun get-new-symbols ()
  (let ((probe (probef (send (lam-lmc-sym-file-pathname (base-filename-for-version 100000))
			     :new-version :newest))))
    (if (null probe)
	(ferror "can't find symbol table ~a" probe))
    (cond ((null (lam-select-symbols-for-version-if-possible (send probe :version)))
	   (lam-load-ucode-symbols-for-version (send probe :version)))))
  )

(defun (:property select-correct-symbols lam-colon-cmd) (ignore)
  (declare (special dtp-fix))
  (let ((ucode-version (lam-ucode-version-from-machine)))
    (cond ((null ucode-version))
	  ((lam-select-symbols-for-version-if-possible ucode-version))
	  ((fquery nil "~&Not loaded ... Load from file? ")
	   (lam-load-ucode-symbols-for-version ucode-version))))
  (format t "~&"))

(defun lam-ucode-version-from-machine ()
  (let* ((ucode-version (lam-register-examine (+ raamo 40)))
	 (24-bit (= (ldb (byte 5 24.) ucode-version) dtp-fix))
	 (25-bit (= (ldb (byte 5 25.) ucode-version) dtp-fix)))
    (setq ucode-version (logand 77777777 ucode-version))
    (cond ((and (null 24-bit) (null 25-bit))
	   (format t "~&40@a doesn't seem to contain a fixnum")
	   nil)
	  ((fquery nil "~&Microcode version ~d.  Ok? " ucode-version)
	   ucode-version))))

(DEFUN LAM-INITIALIZE-SYMBOL-TABLE (DONT-END INITIAL-SYMBOL-ALIST)
  (SETQ LAM-SYMBOLS-VALUE (*ARRAY NIL T LAM-SYMBOLS-ARRAY-SIZE))
  (SETQ LAM-SYMBOLS-NAME (*ARRAY NIL T LAM-SYMBOLS-ARRAY-SIZE))
  (SETQ LAM-SYMBOLS-SIZE 0)
  
  (DO ((L INITIAL-SYMBOL-ALIST (CDR L)))
      ((NULL L))
    (LAM-ADD-SYMBOL (CAAR L) (EVAL (CDAR L))))
  (OR DONT-END (LAM-END-ADDING-SYMBOLS))
  )

(DEFUN LAM-ADD-SYMBOL (NAME VALUE)
  (LET ((I LAM-SYMBOLS-SIZE))
    (DECLARE (FIXNUM I))
    (COND ((= I LAM-SYMBOLS-ARRAY-SIZE)			;ABOUT TO STORE OUT OF ARRAY BOUNDS
	   (SETQ LAM-SYMBOLS-ARRAY-SIZE (+ 400 LAM-SYMBOLS-ARRAY-SIZE))
           (ADJUST-ARRAY-SIZE LAM-SYMBOLS-NAME LAM-SYMBOLS-ARRAY-SIZE)
           (ADJUST-ARRAY-SIZE LAM-SYMBOLS-VALUE LAM-SYMBOLS-ARRAY-SIZE)))
    (LET ((C (CONS NAME VALUE)))
      (ASET C LAM-SYMBOLS-NAME I)
      (ASET C LAM-SYMBOLS-VALUE I)
      (SETQ LAM-SYMBOLS-SIZE (1+ I)))))

(DEFUN LAM-END-ADDING-SYMBOLS ()
  (ADJUST-ARRAY-SIZE LAM-SYMBOLS-NAME LAM-SYMBOLS-SIZE)
  (ADJUST-ARRAY-SIZE LAM-SYMBOLS-VALUE LAM-SYMBOLS-SIZE)
  (cond ((fboundp 'si:merge-sort)
	 (setq lam-symbols-name
	       (fillarray nil (si:merge-sort (listarray lam-symbols-name)
					     #'alphalessp
					     #'car)))
	 (setq lam-symbols-value
	       (fillarray nil (si:merge-sort (listarray lam-symbols-value)
					     #'lam-value-sorter
					     #'identity))))
	(t
	 (SORTCAR LAM-SYMBOLS-NAME (FUNCTION ALPHALESSP))
	 (SORT LAM-SYMBOLS-VALUE (FUNCTION LAM-VALUE-SORTER)))))

(DEFUN LAM-VALUE-SORTER (X Y)
   (< (CDR X) (CDR Y)))

(DEFUN LAM-LOOKUP-NAME (NAME)
    (DO ((FIRST 0)
	 (LAST (1- LAM-SYMBOLS-SIZE)))
	((> FIRST LAST) NIL)
      (LET ((J (// (+ FIRST LAST) 2)))
	 (LET ((E (AREF LAM-SYMBOLS-NAME J)))
	    (LET ((S (CAR E)))
	       (COND ((EQ S NAME)
		      (RETURN (CDR E)))
		     ((ALPHALESSP NAME S)
		      (SETQ LAST (1- J)))
		     (T (SETQ FIRST (1+ J)))))))))

(DEFUN LAM-LOOKUP-VALUE (VALUE)
    (DO ((FIRST 0)
	 (LAST (1- LAM-SYMBOLS-SIZE)))
	((> FIRST LAST) NIL)
      (LET ((J (// (+ FIRST LAST) 2)))
	 (LET ((E (aref LAM-SYMBOLS-VALUE J)))
	    (LET ((N (CDR E)))
	       (COND ((= N VALUE)
		      (RETURN (CAR E)))
		     ((< VALUE N)
		      (SETQ LAST (1- J)))
		     (T (SETQ FIRST (1+ J)))))))))

;; Returns the index to the smallest string greater than or equal to NAME.
(DEFUN LAM-FIND-NAME (NAME)
    (DO ((FIRST 0)
	 (LAST (1- LAM-SYMBOLS-SIZE)))
	((> FIRST LAST) (1+ LAST))
      (DECLARE (FIXNUM FIRST LAST))
      (LET ((J (// (+ FIRST LAST) 2)))
	 (DECLARE (FIXNUM J))
	 (LET ((E (aref LAM-SYMBOLS-NAME J)))
	    (LET ((S (CAR E)))
	       (COND ((EQ S NAME)
		      (RETURN J))
		     ((ALPHALESSP NAME S)
		      (SETQ LAST (1- J)))
		     (T (SETQ FIRST (1+ J)))))))))

;; Index to the greatest value <= VALUE.
;; Returns -1 if no symbol < or =.
(DEFUN LAM-FIND-VALUE (VALUE)
    (DO ((FIRST 0)
	 (LAST (1- LAM-SYMBOLS-SIZE)))
	((> FIRST LAST) LAST)
      (DECLARE (FIXNUM FIRST LAST))
      (LET ((J (// (+ FIRST LAST) 2)))
	 (DECLARE (FIXNUM J))
	 (LET ((E (aref LAM-SYMBOLS-VALUE J)))
	    (LET ((N (CDR E)))
	      (DECLARE (FIXNUM N))
	       (COND ((= N VALUE)
		      (RETURN J))
		     ((< VALUE N)
		      (SETQ LAST (1- J)))
		     (T (SETQ FIRST (1+ J)))))))))

(DEFUN LAM-FIND-CLOSEST-SYM (REG-ADR)
   (DECLARE (FIXNUM REG-ADR))
   (LET ((I (LAM-FIND-VALUE REG-ADR)))
     (DECLARE (FIXNUM I))
     (COND ((NOT (< I 0))
	    (LET ((E (ARRAYCALL T LAM-SYMBOLS-VALUE I)))
		 (LET ((NAME (CAR E)) (DELTA (- REG-ADR (CDR E))))
		      (DECLARE (FIXNUM DELTA))
		      (COND ((ZEROP DELTA) NAME)
			    ((AND (> DELTA 0)
				  (< DELTA 100))
			     (LIST NAME DELTA))
			    (T NIL))))))))

(DEFUN LAM-CONSOLE-INIT ()
  (if (send *terminal-io* :operation-handled-p :size-in-characters)
      (SETQ LAM-FIRST-STATUS-LINE
	    (- (MULTIPLE-VALUE-BIND (IGNORE HT)
		   (SEND *TERMINAL-IO* :SIZE-IN-CHARACTERS)
		 HT)
	       9)))
  (COND ((NOT (BOUNDP 'LAM-BREAKPOINT-LIST))
	 (SETQ LAM-BREAKPOINT-LIST NIL LAM-TEMPORARY-BREAKPOINT-LIST NIL)))
  (COND ((NOT (BOUNDP 'LAM-SYMBOLS-NAME))
	 (LAM-INITIALIZE-SYMBOL-TABLE NIL LAM-INITIAL-SYMS)
	 (LAM-RECORD-SYMBOL-TABLE NIL) ))
  nil)



;NEW REGISTERS:
; .IR MAY BE DEPOSITED
;NEW COMMANDS:
; :EX CLOCK THE MACHINE, EXECUTING WHAT'S IN .IR
; :SCOPE RUN MACHINE AT FULL SPEED, REPEATING INSTRUCTION IN .IR
; adr :START   START MACHINE, LET IT RUN
; :LOWLEVEL T TURNS ON LOW-LEVEL MODE, IN WHICH READING MOST REGISTERS
;  GETS WHAT IS CURRENTLY IN THE MACHINE RATHER THAN WHAT IS SAVED,
;  WRITING IS UNAFFACTED.  MAKES THE DISPLAY AT THE BOTTOM OF THE SCREEN USEFUL WITH :EX
; :MODE DISPLAY THE CURRENT MODE-REGISTER (DECODED)
; :CHMODE APPLIES THE BIT-FIELD-EDITOR TO THE MODE-REGISTER.
; :RESTORE DOES A FULL-RESTORE, GETTING SOFTWARE STATE INTO HARDWARE
;UPDATES THE ERROR STATUS BITS AND MICROINSTRUCTION FORMAT FOR THE NEW MACHINE.

;(COMMENT

;(DEFPROP START LAM-COLON-START LAM-COLON-CMD)

;(DEFUN LAM-COLON-START (PC) 
;  (LAM-RESET-MACH)
;  (LAM-WRITE-PC PC)
;  (LAM-NOOP-CLOCK)
;  (LAM-CLOCK)
;  (SPY-WRITE SPY-CLK 1))

;;EXECUTE .IR (I.E. CLOCK MACHINE ONCE)
;(DEFPROP EX LAM-EXECUTE-DOT-IR LAM-COLON-CMD)

;(DEFUN LAM-EXECUTE-DOT-IR (IGNORE)
;  (LAM-CLOCK))

;(SETQ LAM-LOW-LEVEL-FLAG NIL)

;(DEFPROP LOWLEVEL LAM-SET-LOW-LEVEL-MODE LAM-COLON-CMD)

;(DEFUN LAM-SET-LOW-LEVEL-MODE (IGNORE)
;  (PRIN1 '(NIL OR T OR VERY))
;  (SETQ LAM-LOW-LEVEL-FLAG (READ)))

;(DEFUN LAM-PRINT-ERROR-STATUS (ERR-STS)
;       (COND ((EQ LAM-LOW-LEVEL-FLAG 'VERY)
;	      (PRIN1-THEN-SPACE 'VERY-LOW-LEVEL-MODE)
;	      (SETQ ERR-STS (LAM-READ-STATUS)))  ;GET LATEST WORD, IN LOW-LEVEL MODE 
;	     (LAM-LOW-LEVEL-FLAG
;	      (PRIN1-THEN-SPACE 'LOW-LEVEL-MODE)))
;       (LAM-PRINT-SET-BITS ERR-STS '(
;	;FLAG2
;	NIL NIL ;PCS0, PCS1
;	JC-TRUE P-FLT NO-OP IR48 NIL NIL ;NC NC
;	SPUSHD PDLWRITED IMODD IWRITED DESTSPCD WMAPD NIL NIL ;NC NC
;	;FLAG1 (SETQ ERR-STS (LAM-READ-STATUS))  ;GET LATEST WORD, IN LOW-LEVEL MODE --LOSES--

;;NOTE THAT THE BUS DRIVER WHICH DRIVES THE LOW ORDER 8 BITS IS AN INVERTING BUS FRYER.
;;This starts with bit 0 and goes up.
;	 A-MEM-PAR M-MEM-PAR PDL-BUF-PAR SPC-PAR
;	 DISP-PAR C-MEM-PAR MN-MEM-PAR HIGH-ERR 
;	S-RUN SSDONE ANY-ERR (NOT STAT-HALT)
;	(NOT PROM-ENABLE) (NOT LVL-1-MAP-PAR) (NOT LVL-2-MAP-PAR) (NOT CLOCK-WAIT))))

;;Return T if we currently have a main memory parity error.
;;(DEFUN LAM-MN-MEM-PAR-P ()
;;  (LDB-TEST 2601 (LAM-REGISTER-EXAMINE RASTS)))
;;
;;(proclaim '(SPECIAL LAM-MODE-REG-DESC))
;;
;;(SETQ LAM-MODE-REG-DESC
;;      '( (SELECT-FIELD SPEED 0002 (ULTRA-SLOW SLOW NORMAL FAST))
;;	 (SELECT-FIELD ERROR-STOP-ENABLE 0201 (NIL ERROR-STOP-ENABLE))
;;	 (SELECT-FIELD STAT-STOP-ENABLE 0301 (NIL STAT-STOP-ENABLE))
;;	 (SELECT-FIELD PARITY-TRAP-ENABLE 0401 (NIL PARITY-TRAP-ENABLE))
;;	 (SELECT-FIELD PROM-DISABLE 0501 (PROM-ENABLE PROM-DISABLE))
;;	 (SELECT-FIELD RESET-BIT 0601 (NIL RESET-BIT)) ;HA
;; 	 (SELECT-FIELD BOOT-BIT 0701 (NIL BOOT-BIT)) ;HA
;;	 ))
;;
;;(DEFPROP MODE LAM-SHOW-MODE LAM-COLON-CMD)
;;
;;(DEFUN LAM-SHOW-MODE (ARG)
;;  (AND LAM-LOW-LEVEL-FLAG (PRIN1-THEN-SPACE 'LOW-LEVEL-MODE))
;;  (LAM-TYPE-OUT (OR ARG LAM-MODE-REG) LAM-MODE-REG-DESC NIL T))
;;
;;(DEFPROP CHMODE LAM-EDIT-MODE LAM-COLON-CMD)
;;
;;(DEFUN LAM-EDIT-MODE (IGNORE)
;;  (SPY-WRITE SPY-MODE (SETQ LAM-MODE-REG (LAM-TYPE-IN LAM-MODE-REG-DESC LAM-MODE-REG T))))


;(DEFUN (:PROPERTY RESTORE LAM-COLON-CMD) (IGNORE)
;  (LAM-FULL-RESTORE))

;)	;end comment

(DEFUN (:PROPERTY SM-STEP LAM-COLON-CMD) (IGNORE)
  (LAM-FULL-RESTORE)
  (SM-STEP-LOOP)
  (LAM-FULL-SAVE)
  (LAM-CONSOLE-STATUS-DISPLAY NIL))

(DEFUN (:PROPERTY SELECT-TEST LAM-COLON-CMD) (IGNORE)
  (LAM-FULL-RESTORE)
  (SELECT-TEST)
  (LAM-FULL-SAVE)
  (LAM-CONSOLE-STATUS-DISPLAY NIL))

(DEFUN (:PROPERTY lambda-iopb lam-colon-cmd) (ignore) ;used by debuggee
  (funcall (get 'print-active-mapping-regs 'lam-colon-cmd) nil)
  ;(print-lambda-iopb)
  )

(DEFUN (:PROPERTY LAM-IOPB LAM-COLON-CMD) (IGNORE)  ;used by debug program
  (PRINT-DEBUG-NUBUS-IOPB))

(DEFUN (:PROPERTY DEBUG-IOPB LAM-COLON-CMD) (IGNORE)
  (PRINT-DEBUG-NUBUS-IOPB))

(DEFUN (:PROPERTY sdu-iopb lam-colon-cmd) (ignore)
  (print-iopb))

(DEFUN (:PROPERTY prom-iopb lam-colon-cmd) (ignore)
  (print-iopb-via-multibus-mapping-reg 571 (* 240 4))
  ;(print-lambda-iopb)
  )

(DEFUN (:PROPERTY CSM LAM-COLON-CMD) (IGNORE &AUX TEM)
  (FORMAT T "~%CSMADR: ~o  ~s"
	  (SETQ TEM (READ-CSM-ADR))
	  (CSM-SYMBOLIC-LOCATION (LOGAND 3777 TEM)))
  (FORMAT T "~%"))

;do this after SDU hangs.  This just feeds LAMBDA-IOPB at disk to see what happens.
(defun (:property poke-lambda-iopb lam-colon-cmd) (ignore)
  (funcall (get 'print-active-mapping-regs 'lam-colon-cmd) nil)
  (cond ((y-or-n-p "OK?")
  ;compute byte address where disk control should look for IOPB.
	 (let* ((a-multibus-disk-map-base
		  (lam-symbolic-examine-register 'a-multibus-disk-map-base))
		(iopb-multibus-byte-adr (+ (ash a-multibus-disk-map-base 10.)
					;byte address of iopb page.
					   (* 4 (logand 377 640))))) ;byte offset within page.
	     (format t "~%Setting disk IOPB pointer to ~s, page ~s, word adr in page ~s"
		   iopb-multibus-byte-adr
		   (ash iopb-multibus-byte-adr -10.)
		   (logand 377 (ash iopb-multibus-byte-adr -2)))
	     (set-iopb-pointer iopb-multibus-byte-adr nil))
	 (disk-go-command)
	 (wait-for-iopb-completion t 'read-lambda-iopb))))

(DEFUN (:PROPERTY PRINT-ACTIVE-MAPPING-REGS LAM-COLON-CMD) (IGNORE)
  (PRINT-LAMBDA-IOPB)
  (let ((a-multibus-disk-map-base (lam-symbolic-examine-register 'a-multibus-disk-map-base)))
    (format t "~%multibus-mapping-base is ~s" a-multibus-disk-map-base)
    (print-multibus-mapping-register a-multibus-disk-map-base)
    (LET ((NSECTS (LAMBDA-IOPB-NUMBER-OF-SECTORS)))
      (DO ((NB (ash (lambda-iopb-memory-address) -10.) (1+ NB))
	   (C NSECTS (1- C)))
	  ((ZEROP C))
	(print-multibus-mapping-register nb)))))

;this doesnt really locate all these frobs the "best" way.  it will do for now, tho.
(defun print-iopb-via-multibus-mapping-reg (mapping-reg byte-offset-within-page)
  (declare (ignore byte-offset-within-page))
  (print-multibus-mapping-register mapping-reg)
  (print-lambda-iopb)
  (LET ((NSECTS (LAMBDA-IOPB-NUMBER-OF-SECTORS)))
    (DO ((NB (ash (lambda-iopb-memory-address) -10.) (1+ NB))
	 (C NSECTS (1- C)))
	((ZEROP C)
	 (format t "~%~%"))
      (print-multibus-mapping-register nb))))

(DEFUN (:PROPERTY EAGLE-INTIALIZE LAM-COLON-CMD) (IGNORE)
  (INITIALIZE-DISK-CONTROL))

(DEFUN (:PROPERTY INITIALIZE-DISK-CONTROL LAM-COLON-CMD) (IGNORE)
  (INITIALIZE-DISK-CONTROL))

(DEFUN (:PROPERTY RG LAM-COLON-CMD) (IGNORE)
  (PRINT-RG-MODE))

(DEFUN (:PROPERTY RG-MODE LAM-COLON-CMD) (IGNORE)
  (PRINT-RG-MODE))

(DEFUN (:PROPERTY dp lam-colon-cmd) (ignore)
  (print-dp-mode))

(DEFUN (:PROPERTY dp-mode lam-colon-cmd) (ignore)
  (print-dp-mode))

(DEFUN (:PROPERTY mid lam-colon-cmd) (arg)
  (let* ((mid-address (ldb (byte 10. 6) (or arg lam-last-value-typed)))
	 (mid-contents (lam-read-mid mid-address)))
    (format t "~O@mid// ~O ~S " mid-address
	    mid-contents
	    (lam-find-closest-sym (+ mid-contents racmo)))))

(DEFUN (:PROPERTY dump-original-symbols lam-colon-cmd) (arg)
  (do ((address (or arg lam-last-value-typed) (+ address 5)))
      ((send *standard-input* :tyi-no-hang))
    (format t "~%")
    (lam-q-print-bomb address)
    (format t " ")
    (lam-q-print address lam-sexp-prinlevel)))

;;; The following implements limited macrocode breakpoints.
;;; It will not work on anything but cold loads - before the error handler
;;; is set up.  It allows you to lose in many ways, including trying to set
;;; more than one breakpoint, or unsetting a breakpoint before it goes off.
;;; Notice that the only way to continue from a breakpoint is to remove it.

;;; Someday, maybe someone will really do this right, but we can get by with
;;; this for now.

(defvar macro-breakpoint-function)
(defvar macro-breakpoint-lc)
(defvar macro-breakpoint-old-instruction)
(defvar macro-breakpoint-instruction-location)

(defun executed-macro-breakpoint ()
  (lam-register-deposit macro-breakpoint-instruction-location 
			macro-breakpoint-old-instruction)
  (setq lam-saved-micro-stack-ptr 0)
  (setq lam-saved-ir 20000002507)		;(popj)
  (lam-write-lc (- (lam-read-lc) 2))
  (lam-register-deposit rastep 1)		;step the machine once to get back to 
  (setq lam-update-display-flag t)		;macro instruction loop
  (setq lam-open-register nil))

(DEFUN (:PROPERTY macro-ubreak lam-colon-cmd) (ignore)
  "Unset a macro breakpoint"
  (executed-macro-breakpoint))

(DEFUN (:PROPERTY macro-restore lam-colon-cmd) (ignore)
  (lam-register-deposit macro-breakpoint-instruction-location
			macro-breakpoint-old-instruction)
  (format t "~&Done.~&"))

(DEFUN (:PROPERTY macro-break lam-colon-cmd) (ignore)
  "Set a macro breakpoint"
  (setq macro-breakpoint-function lam-last-value-typed)
  (format t "~%Function ")
  (lam-q-print macro-breakpoint-function lam-sexp-prinlevel)
  (format t " What LC ? ")
  (setq macro-breakpoint-lc (read))
  (setq macro-breakpoint-instruction-location (+ macro-breakpoint-function
						 (// macro-breakpoint-lc 2)))
  (setq macro-breakpoint-old-instruction
	(lam-register-examine macro-breakpoint-instruction-location))
  (lam-register-deposit macro-breakpoint-instruction-location
			(if (zerop (logand 1 macro-breakpoint-lc))
			    (dpb 15673 0020 macro-breakpoint-old-instruction)
			  (dpb 15673 2020 macro-breakpoint-old-instruction)))
  (format t "~&Done.~&"))

(DEFUN (:PROPERTY macro-single-step lam-colon-cmd) (arg)
  (cond ((null arg) (setq arg 1)))
  (cond ((= arg 0)
	 (clear-single-step-macro-inst-mode)
	 (format t "~%single-step-macro-instruction-mode cleared"))
	((= arg 1)
	 (set-single-step-macro-inst-mode)
	 (format t "~%single-step-macro-instruction-mode set"))))

;attempts to force macro-code return (n times).
(DEFUN (:PROPERTY force-macro-return lam-colon-cmd) (arg &aux char pc)
  (cond ((null arg) (setq arg 1)))
  (dotimes (c arg)
    (lam-register-deposit rausp 0)
    (LAM-REGISTER-DEPOSIT RASA (LAM-SYMBOLIC-CMEM-ADR 'QMEX1))
    (LAM-SET-BREAKPOINT (+ RACMO (LAM-SYMBOLIC-CMEM-ADR 'QMLP)) NIL)
    (LAM-SYMBOLIC-DEPOSIT-REGISTER 'M-T (DPB %%QF-DATA-TYPE DTP-SYMBOL 0))
    (LAM-REGISTER-DEPOSIT RAGO 0)
 L  (COND ((SETQ CHAR (KBD-TYI-NO-HANG))
	   (LAM-REGISTER-DEPOSIT RASTOP 0)
	   (MAPC 'LAM-UNSET-BREAKPOINT LAM-TEMPORARY-BREAKPOINT-LIST)
	   (return nil))
	  ((ZEROP (LAM-REGISTER-EXAMINE RAGO)) (GO X)))
    (PROCESS-SLEEP 30. "Return Wait")         ;WHY WAIT AS LONG?
    (GO L)      
 x  (lam-register-deposit rastop 0)
    (MAPC 'LAM-UNSET-BREAKPOINT LAM-TEMPORARY-BREAKPOINT-LIST)
    (COND ((NOT (= (SETQ PC (LAM-REGISTER-EXAMINE RAPC))
		   (1+ (LAM-SYMBOLIC-CMEM-ADR 'QMLP))))
	   (cerror ':no-action nil nil "halted-at-unexpected-place ~s" pc))))
  (setq lam-update-display-flag t))

(defun (:PROPERTY COLD-BOOT-AND-DONT-TOUCH LAM-COLON-CMD) (QUAN)
  (LAM-SET-CHECK-PARITY QUAN)
  (LAM-COLD-BOOT NIL ':AND-DONT-TOUCH T))

(DEFUN (:PROPERTY cold-boot lam-colon-cmd) (quan)
  (lam-set-check-parity quan)
  (lam-cold-boot nil))

(DEFUN (:PROPERTY share-cold-boot lam-colon-cmd) (quan)
  (lam-set-check-parity quan)
  (lam-cold-boot nil)
  )

(DEFUN (:PROPERTY cold-boot-and-load-symbols lam-colon-cmd) (quan)
  (lam-set-check-parity quan)
  (lam-cold-boot t))

(defun lam-cold-boot (load-symbols-p &optional &key (wait-for-halt t) (and-dont-touch nil)
		      &aux a-40 a-version)
  (setq a-40 (read-a-mem 40))			;A-VERSION is 40@a
  (setq a-version (logand 77777 a-40))
  (cond ((not (or (= (ldb (byte 5 24.) a-40) dtp-fix)
		  (= (ldb (byte 5 25.) a-40) dtp-fix)))
	 (cerror "Proceed" "a-40 contains ~o; not a version number" a-40)
	 (setq a-version nil)
	 (setq load-symbols-p nil)))
  (cond ((and a-version
	      (lam-select-symbols-for-version-if-possible a-version))
	 (setq load-symbols-p nil)))  ;if correct symbols are available, select them.
	;if this drops thru and load-symbols-p is still true, it will overlap loading
	; symbols while machine boots.

	 (change-processor-switches-in-sys-conf
	   (send *proc* :proc-conf-bus-address)
	   '(%%processor-switch-prom-jumps-to-cold-boot 1))
	 (write-q-reg
	   (logxor  (send *proc* :proc-conf-bus-address)
		    (if (> (send *proc* :rg-slot) 15.)
			#x10000000
		      0)))
	 (lam-go 2)
  (qf-clear-cache nil)
  (if and-dont-touch (lam-proceed nil ':and-dont-touch t)
    (lam-register-deposit rago 0))
  (cond (load-symbols-p
	 (lam-load-ucode-symbols-for-version a-version)
	 (format t "~%SYMBOLS LOADED")))
  (if (and (not and-dont-touch) wait-for-halt)
      (lam-control-p-wait "cold boot")))

(defun lam-select-symbols-for-version-if-possible (version)
  (cond ((and (typep lam-file-symbols-loaded-from 'fs:pathname)
	      (equal (send lam-file-symbols-loaded-from :name) "ULAMBDA")
	      (= version (send lam-file-symbols-loaded-from :version)))
	 t)					;right symbols already loaded
	(t
	 (dolist (st lam-symbol-tables-loaded)
	   (cond ((null (car st)))
		 ((and (typep (car st) 'fs:pathname)
		       (equal (send (car st) :name) "ULAMBDA")
		       (= version (send (car st) :version)))
		  (format t "~%Selecting symbols ~s" (car st))
		  (lam-select-symbol-table (car st))
		  (return T)))))))
  
(DEFUN (:PROPERTY start-prom lam-colon-cmd) (and-dont-touch)
  (lam-start-prom and-dont-touch))

(defun lam-start-prom (and-dont-touch &optional dont-do-tyis)
	 (cond ((send *proc* :disk-share-mode)
		(remove-share-iopb (send *proc* :rg-slot) 3)
		(remove-share-iopb (send *proc* :rg-slot) 4)
		(change-processor-switches-in-sys-conf
		  (send *proc* :proc-conf-bus-address)
		  '(%%processor-switch-prom-jumps-to-cold-boot 0))))
	 (write-q-reg
	   (logxor  (send *proc* :proc-conf-bus-address)
		    (if (> (send *proc* :rg-slot) 15.)
			#x10000000
		      0)))
	 (lam-go 36001)
  (cond ((null and-dont-touch)
	 (lam-register-deposit rago 0)
	 (lam-control-p-wait "prom"))
	(t
	 (cond ((null dont-do-tyis)
		(format t "~&Type space to turn on SM clock")
		(tyi)))
	 (lam-proceed nil ':and-dont-touch t)
	 (if (null dont-do-tyis)
	     (tyi)))))

(defun (:property reboot lam-colon-cmd) (ignore)
  (cond ((typep *proc* 'lambda-via-local-access)
	 (setf (si:%processor-conf-boot-command (send *proc* :proc-conf-pointer))
	       si:%proc-conf-boot-command-boot)
	 (flush-state)
	 (format t "~&Waiting 2 minutes to let SDU finish.  Hit a character if you think it's done.")
	 (if (process-wait-with-timeout "Wait for SDU start" (* 2 60. 60. ;;60.
								;; thats 2 minutes, not 2 hours! barf foo!
								;; doesnt everybody know how to tell time?
								)
					(lambda (window) (send window :listen)) *terminal-io*)
	     (send *terminal-io* :clear-input))	;gobble the character if there was one
	 (lam-control-p-wait))
	(t
	 (format t "~&can't do that"))))

(defun (:property select-processor lam-colon-cmd) (ignore)
  (select-processor-to-debug))

(DEFUN (:PROPERTY CHAOS-METERS LAM-COLON-CMD) (IGNORE)
  (DOLIST (M '("MY-ADDRESS" "MY-SUBNET"
	       "PKTS-FORWARDED" "PKTS-OVER-FORWARDED" "PKTS-BAD-BIT-COUNT"
	       "PKTS-BAD-DEST" "PKTS-BAD-CRC-1" "PKTS-BAD-CRC-2"
	       "PKTS-LOST" "PKTS-MADE" "PKTS-RECEIVED" "PKTS-TRANSMITTED"
	       "PKTS-OTHER-DISCARDED" "LOS-PKT-COUNT" "PKTS-RETRANSMITTED"
	       "PKTS-DUPLICATED" "DATA-PKTS-IN" "DATA-PKTS-OUT"
	       "BAD-PKT-LIST" "LOS-PKTS" "RECENT-HEADERS" "RECENT-HEADERS-POINTER"))
    (LET ((SYM (QF-SYMBOL (INTERN M "CHAOS"))))
      (IF (< SYM 0)
	  (FORMAT T "~%~A NOT FOUND" M)
	(FORMAT T "~%~A:  " M)
	(LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (1+ (QF-POINTER SYM))))))))

(DEFUN (:PROPERTY ETHER-METERS LAM-COLON-CMD) (IGNORE)
		;make sure all strings in these lists are in upper case.
  (DOLIST (M '( "*ETHERNET-PACKETS-RECEIVED*" "*ETHERNET-PACKETS-TRANSMITTED*"
		"*ETHERNET-CHAOS-PKTS-TRANSMITTED*" "*ETHERNET-CHAOS-PKTS-RECEIVED*"
		"*ETHERNET-UNKNOWN-PROTOCOL-PKTS-RECEIVED*"
		"*ETHERNET-LAST-UNKNOWN-PROTOCOL-TYPE*"
		"ETHER-CHAOS-PKTS-OTHER-DISCARDED" "ETHER-CHAOS-PKTS-BAD-BIT-COUNT"
		"ETHER-CHAOS-PKTS-BAD-DEST"))
    (LET ((SYM (QF-SYMBOL (INTERN M "ETHERNET"))))
      (IF (< SYM 0)
	  (FORMAT T "~%~A NOT FOUND" M)
	(FORMAT T "~%~A:  " M)
	(LAM-Q-PRINT-TOPLEV (LAM-MEM-READ (1+ (QF-POINTER SYM))))))))

(DEFUN (:PROPERTY opc-search lam-colon-cmd) (ignore)
  (let ((address-in-control-memory (- (lam-lookup-name (read)) racmo)))
    (dotimes (i (array-dimension lam-saved-opcs 0))
      (cond ((= (aref lam-saved-opcs i) address-in-control-memory)
	     (format t "~&opc ~O// ~A   " i
		     (lam-find-closest-sym (+ (aref lam-saved-opcs i) racmo)))
	     (lam-print-reg-adr-contents
	       (+ (logand 177777 (aref lam-saved-opcs i))
		  racmo)))))))

(defun cm-lookup (address)
  (lam-find-closest-sym (+ racmo address)))

(defun csm-lookup (address)	;arg should be CSM address such as gotten by 1X.
  (CSM-SYMBOLIC-LOCATION (LOGAND 3777 address)))

(defconst summarize-opcs-censor-list
	  '(pgf-l1a p-b-mr1 zero
	    sg-write-block-from-pdl-buffer
  ;each list corresponds to several symbols in a loop, which we only want to hear about once.
  ;unfortunately, the no-op bit is not saved by the history ram,
  ; and some common loops are written in  popj-after-next, conditional-call-back-in 
  ; style.  This causes the return address to show up in the opcs each time around the loop,
  ; unfortunately.  So the first element of each list is a list of symbols NOT to allow
  ; to break up the loop.
	    ( () sg-load-block-into-pdl-buffer sg-l-p-b-1)
	    ( (page-in-make-known pgf-l2a) spht1 spht2)
	    ( () aw-d-0 await-disk await-disk-delay)
	    ( () findcore0 findcore1)
  	    ( () begcm3 begcm4)
	    ( () inimap6 inimap5)
	    ( () load-mp-1)))

(defun (:property summerize-opcs lam-colon-cmd) (ending-address)	;paceism
  (funcall (get 'summarize-opcs 'lam-colon-cmd) ending-address))
(DEFUN (:PROPERTY summarize-opcs lam-colon-cmd) (ending-address)
  (if (null lam-saved-opcs-valid)
      (lam-save-opcs))
  (or ending-address (setq ending-address (ecase (send *proc* :proc-type)
					    (:lambda 7777)
					    (:explorer 1777))))
  (do ((adr 0 (1+ adr))
       (censor-count)
       (censor-symbol)
       (new-censor-symbol)	;may have be a list with do-not-break list on the front.
       (new-real-censor-symbol) ;do-not-break-list is flushed if it was there.
       (last-censor-symbol)
       (opc)
       (regadr)
       (base-sym)
       (last-base-sym)
       (dif)
       (min-dif)
       (max-dif)
       (opc-adr-of-base)
       (ch))
      ((or (>= adr ending-address)
	   (and (setq ch (read-char-no-hang))
		(not (= ch #\space))))
       (cond ((not (null censor-count))
	      (format t "~&**censored ~O ~A's" censor-count censor-symbol)
	      (setq censor-count nil)))
       (cond (last-base-sym
	      (cond ((= (1+ opc-adr-of-base) adr)
		     (format t "~%opc ~o// ~s ~o"
			     opc-adr-of-base
			     last-base-sym
			     min-dif))
		    (t
		     (format t "~%opc ~o-~o// ~A ~o-~o"
			     opc-adr-of-base (1- adr)
			     last-base-sym
			     min-dif max-dif)))))
       nil)
    (setq opc (ecase (send *proc* :proc-type)
		(:lambda (aref lam-saved-opcs adr))
		(:explorer (ldb (byte 14. 0) (send *proc* :read-opc adr)))))
    (cond ((not (zerop opc))
	   (setq regadr (+ opc racmo))
	   (let ((idx (lam-find-value regadr)))
	     (cond ((>= idx 0)
		    (setq base-sym (car (aref lam-symbols-value idx)))
		    (setq last-censor-symbol new-censor-symbol)
		    (cond ((setq new-censor-symbol
				 (memq-or-memql base-sym summarize-opcs-censor-list))
			   (cond (last-base-sym
				  (cond ((= (1+ opc-adr-of-base) adr)
					 (format t "~%opc ~o// ~s ~o"
						 opc-adr-of-base
						 last-base-sym
						 min-dif))
					(t
					 (format t "~%opc ~o-~o// ~A ~o-~o"
						 opc-adr-of-base (1- adr)
						 last-base-sym
						 min-dif max-dif)))
				  (setq last-base-sym nil)))
			   (setq new-real-censor-symbol
				 (if (symbolp new-censor-symbol)
					    new-censor-symbol
					  (cdr new-censor-symbol)))  ;flush do-not-break list
			   (cond ((null censor-count)
				  (setq censor-count 1)
				  (setq censor-symbol new-real-censor-symbol))
				 ((eq new-real-censor-symbol censor-symbol)
				  (setq censor-count (1+ censor-count)))
				 (t
				  (format t "~&**censored ~O ~A's" censor-count censor-symbol)
				  (setq censor-count 1
					censor-symbol new-real-censor-symbol))))
		;following term inplements do-not-break-loop for one frob test.
			  ((and (not (null censor-count))
				(listp last-censor-symbol)
			;	(memq base-sym (car last-censor-symbol))
				(< (1+ adr) ending-address)
				(memq (base-sym-of-opc (1+ adr)) (cdr last-censor-symbol)))
			   (setq censor-count (1+ censor-count)))
			  (t
			   (cond ((not (null censor-count))
				  (format t "~&**censored ~O ~A's" censor-count censor-symbol)
				  (setq censor-count nil)))
			   (cond ((and last-base-sym
				       (not (eq base-sym last-base-sym)))
				  (cond ((= (1+ opc-adr-of-base) adr)
					 (format t "~%opc ~o// ~s ~o"
						 opc-adr-of-base
						 last-base-sym
						 min-dif))
					(t
					 (format t "~%opc ~o-~o// ~A ~o-~o"
					  opc-adr-of-base (1- adr)
					  last-base-sym
					  min-dif max-dif)))))
			   (cond ((not (eq base-sym last-base-sym))
				  (setq last-base-sym base-sym
					opc-adr-of-base adr
					min-dif 1000000
					max-dif -105)))
			   
			   (setq dif (- regadr (cdr (aref lam-symbols-value idx))))
			   (setq min-dif (min min-dif dif)
				 max-dif (max max-dif dif))
			   ;(setq closest-sym (cond ((zerop dif) base-sym)
			   ;      		   (t (list base-sym dif))))
			   ;(format t "~&opc ~O// ~A  " adr closest-sym)
			   ;(lam-print-reg-adr-contents
			   ;  (+ (logand 177777 (aref lam-saved-opcs adr)) racmo))
			   )) )) ) )) )
  (format t "~&"))

(DEFUN (:PROPERTY summarize-opcs-to-buffer lam-colon-cmd) (ending-address)
  (with-open-file (*standard-output* "ed-buffer:opc-summary" :direction :output)
    (if (null lam-saved-opcs-valid)
	(lam-save-opcs))
    (or ending-address (setq ending-address (ecase (send *proc* :proc-type)
					      (:lambda 7777)
					      (:explorer 1777))))
    (do ((adr 0 (1+ adr))
	 (censor-count)
	 (censor-symbol)
	 (new-censor-symbol)			;may have be a list with do-not-break list on the front.
	 (new-real-censor-symbol)		;do-not-break-list is flushed if it was there.
	 (last-censor-symbol)
	 (opc)
	 (regadr)
	 (base-sym)
	 (last-base-sym)
	 (dif)
	 (min-dif)
	 (max-dif)
	 (opc-adr-of-base)
	 (ch))
	((or (>= adr ending-address)
	     (and (setq ch (read-char-no-hang))
		  (not (= ch #\space))))
	 (cond ((not (null censor-count))
		(format t "~&**censored ~O ~A's" censor-count censor-symbol)
		(setq censor-count nil)))
	 (cond (last-base-sym
		(cond ((= (1+ opc-adr-of-base) adr)
		       (format t "~%opc ~o// ~s ~o"
			       opc-adr-of-base
			       last-base-sym
			       min-dif))
		      (t
		       (format t "~%opc ~o-~o// ~A ~o-~o"
			       opc-adr-of-base (1- adr)
			       last-base-sym
			       min-dif max-dif)))))
	 nil)
      (setq opc (ecase (send *proc* :proc-type)
		  (:lambda (aref lam-saved-opcs adr))
		  (:explorer (ldb (byte 14. 0) (send *proc* :read-opc adr)))))
      (cond ((not (zerop opc))
	     (setq regadr (+ opc racmo))
	     (let ((idx (lam-find-value regadr)))
	       (cond ((>= idx 0)
		      (setq base-sym (car (aref lam-symbols-value idx)))
		      (setq last-censor-symbol new-censor-symbol)
		      (cond ((setq new-censor-symbol
				   (memq-or-memql base-sym summarize-opcs-censor-list))
			     (cond (last-base-sym
				    (cond ((= (1+ opc-adr-of-base) adr)
					   (format t "~%opc ~o// ~s ~o"
						   opc-adr-of-base
						   last-base-sym
						   min-dif))
					  (t
					   (format t "~%opc ~o-~o// ~A ~o-~o"
						   opc-adr-of-base (1- adr)
						   last-base-sym
						   min-dif max-dif)))
				    (setq last-base-sym nil)))
			     (setq new-real-censor-symbol
				   (if (symbolp new-censor-symbol)
				       new-censor-symbol
				     (cdr new-censor-symbol)))	;flush do-not-break list
			     (cond ((null censor-count)
				    (setq censor-count 1)
				    (setq censor-symbol new-real-censor-symbol))
				   ((eq new-real-censor-symbol censor-symbol)
				    (setq censor-count (1+ censor-count)))
				   (t
				    (format t "~&**censored ~O ~A's" censor-count censor-symbol)
				    (setq censor-count 1
					  censor-symbol new-real-censor-symbol))))
						;following term inplements do-not-break-loop for one frob test.
			    ((and (not (null censor-count))
				  (listp last-censor-symbol)
						;	(memq base-sym (car last-censor-symbol))
				  (< (1+ adr) ending-address)
				  (memq (base-sym-of-opc (1+ adr)) (cdr last-censor-symbol)))
			     (setq censor-count (1+ censor-count)))
			    (t
			     (cond ((not (null censor-count))
				    (format t "~&**censored ~O ~A's" censor-count censor-symbol)
				    (setq censor-count nil)))
			     (cond ((and last-base-sym
					 (not (eq base-sym last-base-sym)))
				    (cond ((= (1+ opc-adr-of-base) adr)
					   (format t "~%opc ~o// ~s ~o"
						   opc-adr-of-base
						   last-base-sym
						   min-dif))
					  (t
					   (format t "~%opc ~o-~o// ~A ~o-~o"
						   opc-adr-of-base (1- adr)
						   last-base-sym
						   min-dif max-dif)))))
			     (cond ((not (eq base-sym last-base-sym))
				    (setq last-base-sym base-sym
					  opc-adr-of-base adr
					  min-dif 1000000
					  max-dif -105)))
			     
			     (setq dif (- regadr (cdr (aref lam-symbols-value idx))))
			     (setq min-dif (min min-dif dif)
				   max-dif (max max-dif dif))
						;(setq closest-sym (cond ((zerop dif) base-sym)
						;      		   (t (list base-sym dif))))
						;(format t "~&opc ~O// ~A  " adr closest-sym)
						;(lam-print-reg-adr-contents
						;  (+ (logand 177777 (aref lam-saved-opcs adr)) racmo))
			     )) )) ) )) )
    (format t "~&")))

(defun base-sym-of-opc (opc-adr)
  (let ((idx (lam-find-value (+ racmo (ecase (send *proc* :proc-type)
					(:lambda (aref lam-saved-opcs opc-adr))
					(:explorer (ldb (byte 14. 0)
							(send *proc* :read-opc opc-adr))))))))
    (cond ((>= idx 0)
	   (car (aref lam-symbols-value idx))))))

;if this returns a symbol, its the symbol to be censored.
;if a list, the first element is a list of symbols NOT to break the loop.
; the remainder of the list is the list of symbols of the loop.
(defun memq-or-memql (sym list-or-list-of-lists)
  (do ((p list-or-list-of-lists (cdr p))
       (e))
      ((null p) nil)
    (setq e (car p))
    (cond ((atom e)
	   (if (eq e sym)
	       (return e)))
	  ((memq sym (cdr e))
	   (return e)))))



;search opcs for uinsts which modify given register address (or open location if none).
;also set range for possible following :affect command. (see below)
(DEFUN (:PROPERTY modify lam-colon-cmd) (reg-adr)
  (lam-modify-search reg-adr 7777))

(defvar lam-last-modify-first-adr)
(defvar lam-last-modify-first-adr-contents)

(defun lam-modify-search (reg-adr stop-opc-index)
  (if (null lam-saved-opcs-valid)
      (lam-save-opcs))
  (prog (range reg point-set-flag)
	(cond ((null reg-adr)
	       (if lam-open-register
		   (setq reg-adr lam-open-register)
		 (ferror "No argument nor open register"))
	       (format t "~%Finding opc uinsts which modify ")
	       (lam-print-address reg-adr)))
	(setq range (lam-find-reg-adr-range reg-adr))
	(cond ((eq range 'a)
	       (setq reg (- reg-adr raamo)))
	      ((eq range 'm)
	       (setq reg (- reg-adr rammo)))
	      ((and (memq range '(lam fd))
		    (setq reg (lam-reg-adr-to-func-dest reg-adr))))
	      ((eq range '2c)
	       (setq reg lam-func-dest-l2-map-control))
	      ((eq range '2p)
	       (setq reg lam-func-dest-l2-map-physical-page))
	      (t (ferror "~%I dont know how to deal with range ~s" range)))
	(do ((adr 0 (1+ adr))
	     (opc) (uinst))
	    ((or  (= adr stop-opc-index)
		  (kbd-tyi-no-hang))
	     (format t "~&Done.~&"))
	  (setq opc (aref lam-saved-opcs adr))
	  (cond ((not (= opc 0))
		 (setq uinst (read-cram opc))
		 (cond ((<= (ldb lam-ir-op uinst) 1)
			(cond ((= 1 (ldb lam-ir-a-mem-dest-flag uinst))
			       (cond ((and (eq range 'a)
					   (= reg (ldb lam-ir-a-mem-dest uinst)))
				      (lam-modify-print opc adr point-set-flag)
				      (setq point-set-flag t))))
			      (t
			       (cond ((and (eq range 'm)
					   (= reg (ldb lam-ir-m-mem-dest uinst)))
				      (lam-modify-print opc adr point-set-flag)
				      (setq point-set-flag t))
				     ((and (memq range '(lam fd 2c 2p))
					   (= reg (ldb lam-ir-func-dest uinst)))
				      (lam-modify-print opc adr point-set-flag)
				      (setq point-set-flag t))))))))))))

(defun lam-modify-print (opc adr point-set-flag)
  (setq opc (logand 177777 opc))
  (let ((closest-sym (lam-find-closest-sym (+ opc racmo))))
    (format t "~%OPC+~S//   ~S   ~S  " adr opc closest-sym)
    (lam-print-reg-adr-contents (+ opc racmo))
    (cond ((null point-set-flag)
	   (setq lam-last-open-register (+ opc racmo))
	   (setq lam-last-modify-first-adr adr)
	   (setq lam-last-modify-first-adr-contents lam-last-open-register)))))

;search opcs for uinst which "affect" current uinst (modify its A or M address).
;(if reg-adr is null, current open location is used.)
;If this location is the same as the first opc found in the last :modify command,
; just the range of OPCs up to that opc is searched, otherwise, all opcs are searched.
(DEFUN (:PROPERTY affect lam-colon-cmd) (reg-adr &aux range reg)
  (cond ((null reg-adr)
	 (setq reg-adr lam-last-open-register)))
  (setq range (lam-find-reg-adr-range reg-adr))
  (cond ((eq range 'c)
	 (setq reg (- reg-adr racmo)))
	(t (ferror "~%I dont know how to deal with range ~s" range)))
  (let ((high 7777))
    (cond ((= lam-last-modify-first-adr-contents reg-adr)
	   (format t "~%Searching OPCs in range 0 to ~s" lam-last-modify-first-adr)
	   (setq high lam-last-modify-first-adr)))
    (prog (uinst m-src a-src search-reg-adr)
	  (setq uinst (lam-register-examine reg-adr)
		m-src (ldb lam-ir-m-src uinst)
		search-reg-adr (lam-m-src-to-register-address m-src))
	  (cond ((null search-reg-adr)
		 (format t "~%Dont know how to search for modifiers of m-source ~s" m-src))
		(t
		 (format t "~%Modifiers of M source ")
		 (lam-print-address search-reg-adr)
		 (format t "~%")
		 (lam-modify-search search-reg-adr high)))
	  (setq a-src (ldb lam-ir-a-src uinst))
	  (setq search-reg-adr (+ a-src raamo))
	  (format t "~%Modifiers of A source ")
	  (lam-print-address search-reg-adr)
	  (format t "~%")
	  (lam-modify-search search-reg-adr high))))

(defun lam-m-src-to-register-address (m-src)
  (cond ((zerop (logand 100 m-src))
	 (+ m-src rammo))
	((= m-src lam-m-src-lc)
	 ralc)
	((= m-src lam-m-src-stat-counter)
	 rastat)
	((= m-src lam-m-src-md)
	 ramd)
	((= m-src lam-m-src-vma)
	 ravma)
	((= m-src lam-m-src-pp)
	 rapp)
	((= m-src lam-m-src-pi)
	 rapi)
	((= m-src lam-m-src-q)
	 raq)
	(t nil)))

(defun lam-reg-adr-to-func-dest (reg-adr)
  (cond ((= reg-adr ralc)
	 lam-func-dest-lc)
	((= reg-adr rastat)
	 lam-func-dest-stat-counter)
	((= reg-adr rapp)
	 lam-func-dest-pp)
	((= reg-adr rapi)
	 lam-func-dest-pi)
	((= reg-adr ravma)
	 lam-func-dest-vma)		;*** it really needs to search for more than this.
	((= reg-adr ramd)
	 lam-func-dest-md)))		;*** ditto.


(defun (:property dump-macro-history lam-colon-cmd) (ignore)
  (let ((history-pointer (lam-symbolic-examine-register 'a-macro-history-pointer)))
    (do ((p (1- history-pointer) (1- p))
	 (c 0 (1+ c)))
	((= p history-pointer))
      (cond ((< p 2300) (setq p 3777)))
      (format t "~%~s	" c)
  ;   (lam-type-out (lam-register-examine (+ raamo p)) 'lam-inst-desc nil t)
      (lam-q-print-toplev (lam-register-examine (+ raamo p))))))

(DEFUN (:PROPERTY SYSTEM-COMMUNICATION-AREA LAM-COLON-CMD) (IGNORE)
  (DO ((SYS-COM-Q SYSTEM-COMMUNICATION-AREA-QS (CDR SYS-COM-Q))
       (ADR 400 (1+ ADR))
       Q)
      ((NULL SYS-COM-Q))
    (FORMAT T "~%~s:	~s, ~s"
	    (CAR SYS-COM-Q)
	    (SETQ Q (PHYS-MEM-READ ADR))
	    (NTH (LDB %%QF-DATA-TYPE Q) Q-DATA-TYPES)
	    ())))

(DEFUN (:PROPERTY scratch-pad-init-area lam-colon-cmd) (ignore)
  (DO ((SYS-COM-Q si:scratch-pad-pointers (CDR SYS-COM-Q))
       (ADR 1000 (1+ ADR))
       Q)
      ((NULL SYS-COM-Q))
    (FORMAT T "~%~s:	~s, ~s"
	    (CAR SYS-COM-Q)
	    (SETQ Q (PHYS-MEM-READ ADR))
	    (NTH (LDB %%QF-DATA-TYPE Q) Q-DATA-TYPES)
	    ())))

(DEFUN (:PROPERTY select-speed lam-colon-cmd) (ignore)
  (init-tram t)
  (format t "~%"))

(DEFUN (:PROPERTY cache-on lam-colon-cmd) (ignore)
  (lam-symbolic-deposit-register 'a-l2-map-control-bits
   (logior 40000 (lam-symbolic-examine-register 'a-l2-map-control-bits)))
  (lam-symbolic-deposit-register 'a-processor-switches
   (logior 3_2  (lam-symbolic-examine-register 'a-processor-switches)))
  (enable-cache))

(DEFUN (:PROPERTY cache-off lam-colon-cmd) (ignore)
  (lam-symbolic-deposit-register 'a-l2-map-control-bits
   (logand (lognot 40000) (lam-symbolic-examine-register 'a-l2-map-control-bits)))
  (lam-symbolic-deposit-register 'a-processor-switches
   (logand (lognot 3_2)  (lam-symbolic-examine-register 'a-processor-switches)))
  (disable-cache))

(defun (:property cache-reset lam-colon-cmd) (ignore)
  (lam-reset-cache)
  (reset-mi)
  (setq lam-update-display-flag t))


(defun (:property parity-on lam-colon-cmd) (ignore)
  (setq lam-running-check-parity t)
  (format t "~%On proceed, parity will be enabled for ~s"
	  default-parity-enable-list))

(defun (:property parity-off lam-colon-cmd) (ignore)
  (lam-parity-off))

(defun (:property stat2-clock-on lam-colon-cmd) (ignore)
  (lam-select-stat2-clock)
  (lam-symbolic-register-ior 'a-processor-switches 1_31.))

(defun (:property stat2-clock-off lam-colon-cmd) (ignore)
  (lam-symbolic-register-andcam 'a-processor-switches 1_31.))

(defun (:property misc-decode-on lam-colon-cmd) (ignore)
  (write-rg-mode (dpb 1 enable-misc-mid (read-rg-mode))))

(defun (:property misc-decode-off lam-colon-cmd) (ignore)
  (write-rg-mode (dpb 0 enable-misc-mid (read-rg-mode))))

(defun (:property select-parity-enables lam-colon-cmd) (ignore)
  (select-parity-enables))

(defun (:property set-block-mode lam-colon-cmd) (code)
  (if (null code) (setq code 0))
  (lam-symbolic-deposit-register 'a-l2-map-control-bits
    (dpb code (byte 2 11.)
	 (lam-symbolic-examine-register 'a-l2-map-control-bits)))
  (format t "~%Setting packet code to ~s" code))

;(defun select-parity-enables ()
;  (do ((choice) (tem))
;      (())
;    (setq choice (tv:menu-choose '(exit enable-dp enable-cm enable-mi enable-rg
;					enable-tram enable-mid
;					disable-dp disable-cm disable-mi disable-rg
;					disable-tram disable-mid)
;				 (format nil "~s" default-parity-enable-list)))
;    (cond ((eq choice 'exit)
;	   (return t))
;	  ((setq tem (assq choice '((enable-dp . dp) (enable-cm . cm)
;				    (enable-mi . mi) (enable-rg . rg)
;				    (enable-tram . tram) (enable-mid . mid))))
;	   (push (cdr tem) default-parity-enable-list))
;	  ((setq tem (assq choice '((disable-dp . dp) (disable-cm . cm)
;				    (disable-mi . mi) (disable-rg . rg)
;				    (disable-tram . tram) (disable-mid . mid))))
;	   (setq default-parity-enable-list (delq (cdr tem) default-parity-enable-list))))))
;

(defun select-parity-enables ()
  (let ((p default-parity-enable-list)
	choices)
    (setq choices
	  (tv:multiple-choose "Select parity enables"
			      `((TRAM "TRAM" ((doit ,(memq 'tram p))))
				(MID "MID" ((doit ,(memq 'mid p))))
				(DP "DP" ((doit ,(memq 'dp p))))
				(MI "MI" ((doit ,(memq 'mi p))))
				(CM "CM" ((doit ,(memq 'cm p)))))
			      '((doit "Enabled"))))
    (cond ((not (null choices))
	   (setq default-parity-enable-list nil)
	   (dolist (c choices)
	     (cond ((not (null (cdr c)))
		    (push (car c) default-parity-enable-list))))))))

(defun lam-why-pc (&aux ucode-version)
  (format t "~&Please enter the version number of the microcode the machine was running.~%")
  (setq ucode-version (or (prompt-and-read '(:number :input-radix 10. :or-nil t)
					   "UCODE version (default ~D)> "
					   si:%microcode-version-number)
			  si:%microcode-version-number))
  (or (lam-select-symbols-for-version-if-possible ucode-version)
      (lam-load-ucode-symbols-for-version ucode-version))
  (format t "Please enter the PC's printed by the 'why' program. 
Entering -1 exits this program, <~:C> does a reprint.~%" #\Return)
  (do ((pc))
      ((and (setq pc (prompt-and-read '(:number :input-radix 8. :or-nil t)
				       "~&PC>"))
	    (minusp pc)))
    (and pc (cram-symbolic-address pc))))

(defun cram-symbolic-address (adr)
  (format t "~&~o@c " adr)
  (lam-print-address (+ adr racmo)))

(defun (:property print-unibus-channels lam-colon-cmd) (ignore)
  (do ((x (qf-pointer (phys-mem-read (+ 400 %sys-com-unibus-interrupt-list)))
	  (qf-p-pointer (+ x %unibus-channel-link)))
       (p nil x))
      ((zerop x))
    (format t "~%channel at ~s: vector ~s, csr adr ~s, csr bits ~s, data adr ~s"
	    x
	    (qf-p-pointer (+ x %unibus-channel-vector-address))
	    (qf-p-pointer (+ x %unibus-channel-csr-address))
	    (qf-p-pointer (+ x %unibus-channel-csr-bits))
	    (qf-p-pointer (+ x %unibus-channel-data-address)))))

(defun (:property foothold lam-colon-cmd) (arg)
  (if (null arg)
      (setq arg lam-last-open-register))
  (cond ((not (= (qf-p-data-type arg) dtp-fef-pointer))
	 (format t "   not a call block   "))
	(t
	 (do* ((qs stack-group-head-leader-qs (cdr qs))
	       address)
	      ((null qs))
	   (setq address (+ 1 arg (* 2 (symeval (car qs)))))
	   (format t "~&~o ~s ~35t#<" address (car qs))
	   (lam-type-out
	     (qf-smash-data-type (qf-pointer (lam-register-examine address))
				 (qf-pointer (lam-register-examine (1+ address))))
	     'lam-q-desc t nil)
	   (format t ">"))))) 

(defun (:property int-level lam-colon-cmd) (ignore)
  (format t " #o~o " (ldb (byte 4 16.) (send *proc* :read-mcr))))


(defun compare-opc-arrays (a1 a2 &optional (offset-1 0) (offset-2 0))
  (let ((count (min (- (array-length a1) offset-1)
		    (- (array-length a2) offset-2))))
    (do ((c 0 (1+ c))
	 (wins 0)
	 (losses 0)
	 (typeouts 0))
	((>= c count)
	 (format t "~%Wins ~s, losses ~s" wins losses))
      (cond ((= (aref a1 (+ c offset-1))
		(aref a2 (+ c offset-2)))
	     (incf wins))
	    ((> typeouts 5)
	     (incf losses))
	    (t
	     (Format t "~%At offset ~S, a1 = ~s, a2 = ~s, ~d wins to now"
		     c (aref a1 (+ c offset-1)) (aref a2 (+ c offset-2)) wins)
	     (incf losses))))))