source: trunk/lisp/lmcons/cc.lisp @ 213

Last change on this file since 213 was 213, checked in by rjs, 7 years ago

Update.

File size: 99.5 KB
Line 
1; -*- Mode:Lisp; Package:CADR; Base:8 -*-
2;READ IN LISPM;MACROS > BEFORE RUNNING THIS INTERPRETED.
3;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
4
5(INCLUDE |LMDOC;.COMPL PRELUD|)
6#M (DECLARE (MACROS NIL))       ;I suppose this won't do any good....
7(INCLUDE |LMCONS;QFMAC >|)
8
9;Cons Machine Console Program
10
11;Documentation:
12
13;It's like DDT
14
15;Further Documentation:
16;
17;^R     reset
18;^N     step
19;n^N    step n times, n < 40000
20;adr^N  step until about to execute micro instr at adr
21;^P     run until char typed (lisp machine uses its own console)
22;^L     clear screen
23;^T     enter remote console mode, type ^S to leave
24;105 FOOBAR  start machine
25;
26; :AREAS  give information about areas
27; :AREA   prints area that last value typed points to.
28; :MAPS   prints maps (1st and 2nd level) addressed by last value typed.
29; :STKP   give backtrace of info on stack. Preceeding numeric arg is number of
30;         frames worth.  All are printed if arg is absent.  If arg negative,
31;         print (abs arg) frames direct from PDL-BUFFER (bypassing memory mapping, etc).
32;         Any character typed during printout will abort rest of printout.
33; :TRACE  like :STKP except that if the last value examined is a stack group
34;         that stack group will be traced instead of the current one.
35; :ATOM foo  tell about atomic symbol foo
36; :BACTRACE
37; :BACKTRACE
38; :MEMSTAT tell all about all pages that are swapped in
39; :RELPC  types out what M-AP points to, and if thats a FEF, prints out what
40;         LC is relative to that.
41; :CODE   disassembles the macrocoded function being executed.
42; :DISASSEMBLE-FEF  disassembles last quantity typed.  Asks for center-PC or NIL.
43; :CHECK-MAP  checks contents of hardware map against PAGE-HASH-TABLE.
44; :PF    Interprets open register as LP-FEF Q of a PDL-FRAME, and prints
45;         the entire frame.
46; :FLAGS  Decode M-FLAGS
47; :INTOFF disable machine interrupts
48; arg :PHYS-MEM-WORD-SEARCH   Searches real core for arg  **CROCK** FOR NOW IT ONLY
49;                               SEARCHES 128K.  FIX WHEN CC KNOWS ABOUT REAL MEM.
50; :DESCRIBE  if last quantity typed is a closure or entity, prints CLOSURE-ALIST sort
51;             of thing.  if a stack-group, prints info from stack group header.
52; :PCHECK    Use this to track down problems with hardware parity checkers.
53;          Types what the parity generator chips for the last quantity examined
54;          should put out.  Works for C-MEM ..add others.. .
55
56; in CADRD:
57;
58; :START -  adr :START,   start machine, let it run
59; :LOWLEVEL -  :LOWLEVEL T turns on low-level mode, in which reading most registers
60;    gets what is currently in the machine rather than what is saved,
61;    writing is unaffacted.  Makes the display at the bottom of the screen useful with :EX
62;    :LOWLEVEL VERY enters a mode where CC tries not to "spontaneously" affect the
63;    hardware in any way.  This means only the "passive" machine state is available,
64;    ie no saving - frobbing - restoring is permitted.  If random things not part of
65;    the passive state are examined, etc, ideally the saving, etc should be done
66;    at that time.  BE VERY CAREFUL
67; :MODE - Decodes the mode register symbolically
68; :CHMODE - Edits the mode register
69; :RESTORE -  does a full-restore, getting software state into hardware,
70
71; :EX - Execute .IR once.
72; :SCOPE causes the machine to execute whatever is in DEBUG-IR
73;        repeatedly at full speed.  Deposit in .IR just before doing this.
74
75;
76; Breakpoints:
77; :B    set breakpoint at prefix arg or open location
78; :UB   unset breakpoint at ..
79; :LISTB  list breakpoints
80; :UAB  unset all breakpoints
81; :P    proceed
82; :G    do 1@G and :P
83; :TB   set temporary breakpoint at .. (temp bkpt goes away when reached)
84; :TBP  set temporary breakpoint and proceed
85;
86; :HERE   :P connects lisp machine to ITS console
87; :THERE  :P connects lisp machine to its own console
88;
89;Initial Symbols
90; RESET VMA MWD RAIDR PSV FSV RUNNING TRYING-TO-RUN MODE
91; LLMOD NOOPF FDEST FSRC .IR IR PC USP Q DC PP PI CIB OPC
92;
93;   Since there are many different memories in the machine, each having
94;addresses running from 0 to some power of 2, a large space of register addresses
95;is defined, and the various memories are assigned parts of it.
96;A register address can be referred to either by specifying which memory
97;and the address within the memory, as in 200@C for location 200 in control memory,
98;or by specifying the register address, which would be 200+RACMO for that location.
99;
100;100000+n   physical main memory location n
101;1000000+n  virtual memory location n
102;
103;n@C    control memory
104;n@D    dispatch memory
105;n@P    PDL buffer
106;n@1    map 1
107;n@2    map 2
108;n@A    A memory
109;n@U    micro return stack
110;n@M    M memory
111;FS n   functional sources
112;FD n   functional destinations
113;CC n   "special" registers, e.g. PC, USP
114;CSW n  CCONS control switches
115;RAIDR n  Raid registers
116;CIB n  Console inst buffers
117;OPC n  Old PCs
118
119;n@G    set PC
120;@Q     last frob typed (like Q in DDT)
121;
122;_nn    rotate left nn places (32 bits).  follow by space or equals to type out.
123;
124;_H     type out as halfwords LH,,RH
125;_B     type out as bytes (right to left)
126;_Q     type out as lisp Q
127;_A     type out as array header
128;_I     type out as macro instruction
129;_U     type out as micro instruction
130;_V     type out as micro instruction, old style.
131;__     type out as register address
132;_S     type out as lisp machine S expression (ie do PRINT, sort of)
133;         CC-SEXP-PRINLEVEL and CC-SEXP-PRINLENGTH control how deep and
134;         how long things will go, respectively.
135;_#     type out as bit numbers of set bits.
136;` (left slant) instead of _ causes type-in mode
137;In type-in mode, completes what has been typed so far
138; as much as possible, ? lists possible completions, space
139; terminates the syllable.  You can type just a space and
140; if there is one possibility that types nothing in
141; type-out mode, (i.e. a default) it will get used.
142;
143;' (right slant) is similar except typing just a space leaves
144; the field set to its previous value.
145; In the MODE register, bit 1.1=run slow, bit 1.2=disable error halts
146
147(IF-FOR-MACLISP (DECLARE (CLOSED T)))   ;WHEN I USE PLUS AND DIFFERENCE, IT'S FOR A REASON
148(DECLARE (SETQ INHIBIT-STYLE-WARNINGS-SWITCH T)) ;DON'T HASSLE ME ABOUT CALLING GETCHARN
149
150(IF-FOR-MACLISP
151(DEFUN QF-POINTER MACRO (X)
152  (LIST 'LOGAND 77777777 (CADR X))))
153
154(DECLARE (SPECIAL PAGE-SIZE CC-REG-ADR-PHYS-MEM-OFFSET CC-REG-ADR-VIRT-MEM-OFFSET
155                  SG-NAME SG-REGULAR-PDL SG-AP RACMWD RACVMW RACPMW DESC DESC-STACK ITEM
156                  CC-FULL-SAVE-VALID CC-PASSIVE-SAVE-VALID CC-LOW-LEVEL-FLAG
157                  *DONT-TOUCH-MACHINE*))
158(DECLARE (SPECIAL QF-SWAP-IN-LOOP-CHECK))
159
160(DEFVAR SPY-ACCESS-PATH 'TEN11)    ;How we get to main mem
161(DEFVAR CC-ACCESS-PATH NIL)        ;If this a closure, send it messages from
162                                   ;CC-REGISTER-EXAMINE, CC-REGISTER-DEPOSIT.  used by
163                                   ;stuff that looks at UCODE-IMAGES
164
165(DECLARE (NOTYPE (CC-R-E FIXNUM) (CC-R-D FIXNUM NOTYPE)))
166(DECLARE (SPECIAL CC-SYMBOLS-NAME CC-SYMBOLS-VALUE CC-SYMBOLS-SIZE CC-SYMBOLS-ARRAY-SIZE))
167(SETQ CC-SYMBOLS-ARRAY-SIZE 5000) ;CURRENT SIZE OF ARRAYS
168
169;alist (<file-name> cc-symbols-size cc-symbols-name cc-symbols-value)
170#Q (DEFVAR CC-SYMBOL-TABLES-LOADED NIL)
171
172(ARRAY CC-RAID-REG FIXNUM 8)
173(IF-FOR-LISPM (FILLARRAY (FUNCTION CC-RAID-REG) '(0)))
174;(DECLARE (ARRAY* (FIXNUM CC-RAID-REG 8)))
175
176;REGISTER ADDRESSES IN CC:
177;       0 < RACMO                       "NUMBERS"
178;   RACMO < CC-REG-ADR-PHYS-MEM-OFFSET  "REGISTER ADDRESSES" (PDP-11 STYLE)
179;  THENCE < CC-REG-ADR-VIRT-MEM-OFFSET   PHYSICAL MAIN MEM LOCNS ON CONS
180;  ALL ABOVE                             VIRTUAL MAIN MEM LOCNS ON CONS
181
182(IF-FOR-MACLISP (PROGN
183(DEFPROP Q-FASLOAD (FLOAD FASL DSK LMCONS) AUTOLOAD) ))
184
185(DECLARE (FIXNUM (READ-FIXNUM))
186         (NOTYPE (CNSWDB FIXNUM FIXNUM FIXNUM FIXNUM)
187                 (CC-MAIN-MEMORY-BLOCK-WRITE FIXNUM FIXNUM)))
188
189;LISP MACHINE HACKING ROUTINES IN QF
190(DECLARE (NOTYPE (QF-CLEAR-CACHE NOTYPE))       ;FORGET STATE OF MACHINE, ARG=T => ALL
191         (FIXNUM ;(QF-AREA-ORIGIN NOTYPE)       ;ARG = AREA NAME, VALUE = ADDRESS
192                 (QF-INITIAL-AREA-ORIGIN NOTYPE) ; SAME, BUT MUST BE INITIAL AREA. MUCH FASTER.
193                 (QF-SYMBOL NOTYPE)             ;ARG = SYMBOL, VALUE = LISP MACHINE SYMBOL
194                 (QF-VIRTUAL-MEM-READ FIXNUM)   ;READ VIRTUAL ADDRESS
195                 (QF-VIRTUAL-MEM-WRITE FIXNUM FIXNUM)   ;WRITE VIR ADR, DATA
196                 (QF-MEM-READ FIXNUM)           ;READ VIRTUAL, BARF IF INACCESSIBLE
197                 (QF-MEM-WRITE FIXNUM FIXNUM)   ;WRITE VIRTUAL, BARF IF INACCESSIBLE
198 ))
199
200(DECLARE (SPECIAL AREA-LIST %SYS-COM-PAGE-TABLE-PNTR %SYS-COM-PAGE-TABLE-SIZE
201                  %SYS-COM-/#-AREAS))
202
203(DECLARE (SPECIAL CC-INPUT-STREAM CC-OUTPUT-STREAM))
204
205;CONS/CADR PHYSICAL MEMORY HACKING
206
207(DECLARE (FIXNUM (CNSPMR FIXNUM))               ;READ PHYSICAL ADDRESS
208         (FIXNUM (CNSPMW FIXNUM FIXNUM)))       ;WRITE PHYSICAL ADDRESS, DATA
209
210(DECLARE (FIXNUM (PHYS-MEM-READ FIXNUM) (DBG-READ-XBUS FIXNUM))
211         (NOTYPE (PHYS-MEM-WRITE FIXNUM FIXNUM) (DBG-WRITE-XBUS FIXNUM FIXNUM)))
212
213(DEFUN PHYS-MEM-READ (ADR)
214  (COND ((EQ SPY-ACCESS-PATH 'BUSINT)
215         (DBG-READ-XBUS ADR))
216        ((EQ SPY-ACCESS-PATH 'TEN11)
217         (CNSPMR ADR))
218        (T (ERROR '|UNKNOWN SPY-ACCESS-PATH| SPY-ACCESS-PATH))))
219
220(DEFUN PHYS-MEM-WRITE (ADR VAL)
221  (COND ((EQ SPY-ACCESS-PATH 'BUSINT)
222         (DBG-WRITE-XBUS ADR VAL))
223        ((EQ SPY-ACCESS-PATH 'TEN11)
224         (CNSPMW ADR VAL))
225        (T (ERROR '|UNKNOWN SPY-ACCESS-PATH| SPY-ACCESS-PATH)))
226  T)  ;DONT CONS VALUE OF CNSPMW
227
228;SIMPLEMINDED EXAMINE OF REG-ADR (THAT SINGLE ADR, NO OVERLAP, ETC)
229; RETURNS AN INTEGER (POSSIBLY A BIGNUM)
230(DEFUN CC-REGISTER-EXAMINE (REG-ADR)
231  (PROG ()
232        (COND #Q ((CLOSUREP CC-ACCESS-PATH)
233               (RETURN (FUNCALL CC-ACCESS-PATH ':EXAMINE REG-ADR)))
234              ((NOT (< REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET))
235               (RETURN (QF-MEM-READ (- REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET))))
236              ((NOT (< REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET))
237               (RETURN (PHYS-MEM-READ (- REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET)))))
238        (RETURN (CC-R-E REG-ADR))))
239
240;SIMPLEMINDED DEPOSIT OF REG-ADR (THAT SINGLE ADR, NO OVERLAP, ETC)
241
242;SPECIAL REGISTER ADDRESSES - SPECIAL STATUS REGISTERS AND FUNCTIONAL REGISTERS
243; TAKES AS ARG AN INTEGER (POSSIBLY A BIGNUM)
244(DEFUN CC-REGISTER-DEPOSIT (REG-ADR DATA)
245  (PROG ()
246        (COND #Q ((CLOSUREP CC-ACCESS-PATH)
247                  (RETURN (FUNCALL CC-ACCESS-PATH ':DEPOSIT REG-ADR DATA)))
248              ((NOT (< REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET))
249               (RETURN (QF-MEM-WRITE (- REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET) DATA)))
250              ((NOT (< REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET))
251               (RETURN (PHYS-MEM-WRITE (- REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET) DATA))))
252        (RETURN (CC-R-D REG-ADR DATA))))
253
254; SPECIAL STATUS REGISTERS
255;       RUNNING STATUS
256;       ERROR STATUS
257;       OUTPUT BUS READBACK
258
259; FUNCTIONAL REGISTERS ("NORMAL" WAY OF ACCESSING THESE FCTNS IN PARENS)
260;       RESET (CNTRL-R)
261;       STEP  (CNTRL-N)
262;       STOP  (CNTRL-S)
263;       SET STARTING ADR (@G)
264;       GO (CNTRL-P, BUT KEEP LISTENING)
265
266(DECLARE (SPECIAL RAPC RASIR RAIR RAOBS RANOOPF RASTS
267           RACMO RACME RADMO RADME RAPBE RAM1E RAM2E RAAME RAUSE RAMME RAFSE RAFDE
268           RARGE RACSWE RARDRE RACIBE RAGO RASTOP RARDRO RAFDO RAOPCE
269           RARS RASTEP RASA RAAMO RAMMO RARCON RAPBO RAUSO
270           RAM1O RAM1E RAM2O RAM2E RAVMA
271           %%ARRAY-LEADER-BIT %%ARRAY-INDEX-LENGTH-IF-SHORT
272           %%ARRAY-LONG-LENGTH-FLAG
273        %%Q-CDR-CODE %%Q-FLAG-BIT %%Q-DATA-TYPE %%Q-POINTER %%Q-TYPED-POINTER
274        %%M-FLAGS-QBBFL))
275
276(DECLARE (SPECIAL CC-FIRST-STATUS-LINE CC-UPDATE-DISPLAY-FLAG
277                  CC-LAST-OPEN-REGISTER CC-INITIAL-SYMS CC-LAST-VALUE-TYPED
278                  CC-REMOTE-CONSOLE-MODE CC-BREAKPOINT-LIST
279                  CC-TEMPORARY-BREAKPOINT-LIST
280                  CC-OPEN-REGISTER CC-GETSYL-UNRCH CC-GETSYL-UNRCH-TOKEN))
281
282(IF-FOR-MACLISP (DECLARE (SPECIAL CC-TTY-STATUS LISP-TTY-STATUS)))
283
284;;; Symbol table management.
285
286(IF-FOR-LISPM   ;stuff to keep symbol tables around.  Not enuf room in MACLISP for this.
287(DEFUN CC-RECORD-SYMBOL-TABLE (FILENAME)
288  (SETQ CC-SYMBOL-TABLES-LOADED
289        (CONS (LIST FILENAME CC-SYMBOLS-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-VALUE)
290              CC-SYMBOL-TABLES-LOADED))) )
291
292;Select previously loaded symbols.  Return nil if none for file.
293(IF-FOR-LISPM
294(DEFUN CC-SELECT-SYMBOL-TABLE (FILENAME)
295  (LET ((TEM (ASSOC FILENAME CC-SYMBOL-TABLES-LOADED)))
296    (COND (TEM (SETQ CC-FILE-SYMBOLS-LOADED-FROM (CAR TEM)
297                     CC-SYMBOLS-SIZE (CADR TEM)
298                     CC-SYMBOLS-NAME (CADDR TEM)
299                     CC-SYMBOLS-VALUE (CADDDR TEM))
300               T)))
301  ) )
302
303(DEFUN CC-INITIALIZE-SYMBOL-TABLE (DONT-END)
304    (COND (#M (NOT (BOUNDP 'CC-SYMBOLS-NAME)) #Q T
305           (SETQ CC-SYMBOLS-VALUE (*ARRAY NIL T CC-SYMBOLS-ARRAY-SIZE))
306           (SETQ CC-SYMBOLS-NAME (*ARRAY NIL T CC-SYMBOLS-ARRAY-SIZE))))
307    (SETQ CC-SYMBOLS-SIZE 0)
308
309    (DO ((L CC-INITIAL-SYMS (CDR L)))
310        ((NULL L))
311      (CC-ADD-SYMBOL (CAAR L) (EVAL (CDAR L))))
312    (OR DONT-END (CC-END-ADDING-SYMBOLS))
313    )
314
315(DEFUN CC-ADD-SYMBOL (NAME VALUE)
316  (LET ((I CC-SYMBOLS-SIZE))
317    (DECLARE (FIXNUM I))
318    (COND ((= I CC-SYMBOLS-ARRAY-SIZE)                  ;ABOUT TO STORE OUT OF ARRAY BOUNDS
319           (SETQ CC-SYMBOLS-ARRAY-SIZE (+ 400 CC-SYMBOLS-ARRAY-SIZE))
320           #M (*REARRAY CC-SYMBOLS-NAME T CC-SYMBOLS-ARRAY-SIZE)
321           #M (*REARRAY CC-SYMBOLS-VALUE T CC-SYMBOLS-ARRAY-SIZE)
322           #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-ARRAY-SIZE)
323           #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-VALUE CC-SYMBOLS-ARRAY-SIZE)))
324    (LET ((C (CONS NAME VALUE)))
325      #M (STORE (ARRAYCALL T CC-SYMBOLS-NAME I) C)
326      #M (STORE (ARRAYCALL T CC-SYMBOLS-VALUE I) C)
327      #Q (ASET C CC-SYMBOLS-NAME I)
328      #Q (ASET C CC-SYMBOLS-VALUE I)
329      (SETQ CC-SYMBOLS-SIZE (1+ I)))))
330
331(DEFUN CC-END-ADDING-SYMBOLS ()
332   (SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)
333   #M (*REARRAY CC-SYMBOLS-NAME T CC-SYMBOLS-SIZE)
334   #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-SIZE)
335   (SORTCAR CC-SYMBOLS-NAME (FUNCTION ALPHALESSP))
336   #M (*REARRAY CC-SYMBOLS-VALUE T CC-SYMBOLS-SIZE)
337   #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-VALUE CC-SYMBOLS-SIZE)
338   (SORT CC-SYMBOLS-VALUE (FUNCTION CC-VALUE-SORTER)))
339
340(DEFUN CC-VALUE-SORTER (X Y)
341   (< (CDR X) (CDR Y)))
342
343(DEFUN CC-LOOKUP-NAME (NAME)
344    (DO ((FIRST 0)
345         (LAST (1- CC-SYMBOLS-SIZE)))
346        ((> FIRST LAST) NIL)
347      (DECLARE (FIXNUM FIRST LAST))
348      (LET ((J (// (+ FIRST LAST) 2)))
349         (DECLARE (FIXNUM J))
350         (LET ((E (ARRAYCALL T CC-SYMBOLS-NAME J)))
351            (LET ((S (CAR E)))
352               (COND ((EQ S NAME)
353                      (RETURN (CDR E)))
354                     ((ALPHALESSP NAME S)
355                      (SETQ LAST (1- J)))
356                     (T (SETQ FIRST (1+ J)))))))))
357
358(DEFUN CC-LOOKUP-VALUE (VALUE)
359    (DO ((FIRST 0)
360         (LAST (1- CC-SYMBOLS-SIZE)))
361        ((> FIRST LAST) NIL)
362      (DECLARE (FIXNUM FIRST LAST))
363      (LET ((J (// (+ FIRST LAST) 2)))
364         (DECLARE (FIXNUM J))
365         (LET ((E (ARRAYCALL T CC-SYMBOLS-VALUE J)))
366            (LET ((N (CDR E)))
367              (DECLARE (FIXNUM N))
368               (COND ((= N VALUE)
369                      (RETURN (CAR E)))
370                     ((< VALUE N)
371                      (SETQ LAST (1- J)))
372                     (T (SETQ FIRST (1+ J)))))))))
373
374;; Returns the index to the smallest string greater than or equal to NAME.
375(DEFUN CC-FIND-NAME (NAME)
376    (DO ((FIRST 0)
377         (LAST (1- CC-SYMBOLS-SIZE)))
378        ((> FIRST LAST) (1+ LAST))
379      (DECLARE (FIXNUM FIRST LAST))
380      (LET ((J (// (+ FIRST LAST) 2)))
381         (DECLARE (FIXNUM J))
382         (LET ((E (ARRAYCALL T CC-SYMBOLS-NAME J)))
383            (LET ((S (CAR E)))
384               (COND ((EQ S NAME)
385                      (RETURN J))
386                     ((ALPHALESSP NAME S)
387                      (SETQ LAST (1- J)))
388                     (T (SETQ FIRST (1+ J)))))))))
389
390;; Index to the greatest value <= VALUE.
391;; Returns -1 if no symbol < or =.
392(DEFUN CC-FIND-VALUE (VALUE)
393    (DO ((FIRST 0)
394         (LAST (1- CC-SYMBOLS-SIZE)))
395        ((> FIRST LAST) LAST)
396      (DECLARE (FIXNUM FIRST LAST))
397      (LET ((J (// (+ FIRST LAST) 2)))
398         (DECLARE (FIXNUM J))
399         (LET ((E (ARRAYCALL T CC-SYMBOLS-VALUE J)))
400            (LET ((N (CDR E)))
401              (DECLARE (FIXNUM N))
402               (COND ((= N VALUE)
403                      (RETURN J))
404                     ((< VALUE N)
405                      (SETQ LAST (1- J)))
406                     (T (SETQ FIRST (1+ J)))))))))
407
408(DEFUN CC-FIND-CLOSEST-SYM (REG-ADR)
409   (DECLARE (FIXNUM REG-ADR))
410   (LET ((I (CC-FIND-VALUE REG-ADR)))
411     (DECLARE (FIXNUM I))
412     (COND ((NOT (< I 0))
413            (LET ((E (ARRAYCALL T CC-SYMBOLS-VALUE I)))
414                 (LET ((NAME (CAR E)) (DELTA (- REG-ADR (CDR E))))
415                      (DECLARE (FIXNUM DELTA))
416                      (COND ((ZEROP DELTA) NAME)
417                            ((AND (> DELTA 0)
418                                  (< DELTA 20))
419                             (LIST NAME DELTA))
420                            (T NIL))))))))
421
422(SETQ CC-LAST-OPEN-REGISTER 40000)
423
424(IF-FOR-MACLISP
425(SETQ CC-TTY-STATUS '(232320232323 230323030323)
426      LISP-TTY-STATUS NIL) )
427
428(IF-FOR-MACLISP
429(DEFUN CC-SET-TTY-STATUS NIL
430  (PROG (TEM)
431        (SETQ TEM (STATUS TTY))
432        (COND ((NOT (= (CAR TEM) (CAR CC-TTY-STATUS)))
433                (SETQ LISP-TTY-STATUS (LIST (CAR TEM)(CADR TEM)))
434                (SSTATUS TTYINT 23 NIL)
435                (EVAL (CONS 'SSTATUS (CONS 'TTY CC-TTY-STATUS))))))) )
436
437(IF-FOR-MACLISP
438(DEFUN CC-RESTORE-TTY-STATUS NIL
439   (SSTATUS TTYINT 23 27)
440   (COND (LISP-TTY-STATUS
441                (EVAL (CONS 'SSTATUS (CONS 'TTY LISP-TTY-STATUS)))))) )
442
443(DEFUN CC-CONSOLE-INIT NIL
444  (PROG NIL
445        (SETQ CC-FIRST-STATUS-LINE (- #M (CAR (STATUS TTYSIZE))
446                                      #Q (MULTIPLE-VALUE-BIND (IGNORE HT)
447                                             (FUNCALL TERMINAL-IO ':SIZE-IN-CHARACTERS)
448                                           HT)
449                                      9))
450        (COND ((NOT (BOUNDP 'CC-REMOTE-CONSOLE-MODE))
451               (SETQ CC-REMOTE-CONSOLE-MODE T)
452               (SETQ CC-BREAKPOINT-LIST NIL CC-TEMPORARY-BREAKPOINT-LIST NIL)))
453        (COND ((NULL (ARRAYDIMS 'CC-RAID-REG))  ;MADE DEAD BY FASLOAD
454               (*ARRAY 'CC-RAID-REG 'FIXNUM 8)
455               (FILLARRAY 'CC-RAID-REG '(0))))
456        (COND ((NULL (BOUNDP 'RAPC))
457               (READFILE '(CONREG > DSK LISPM))))
458        (COND ((NOT (BOUNDP 'CC-SYMBOLS-NAME))
459               (CC-INITIALIZE-SYMBOL-TABLE NIL)
460               #Q (CC-RECORD-SYMBOL-TABLE NIL) ))
461        (COND ((NOT (AND (BOUNDP 'CC-INPUT-STREAM) (BOUNDP 'CC-OUTPUT-STREAM)))
462               (MAKE-CC-STREAM)))
463        ))
464
465
466;DEFINITIONS OF VARIOUS WORD FORMATS, FOR BOTH TYPE-OUT AND TYPE-IN
467
468(DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC
469                  CC-I-DEST-DESC CC-I-ADDR-DESC CC-I-BR-DESC
470                  CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC CC-I-15-DESC
471                  CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC CC-REG-ADDR-DESC
472                  CC-UINST-DESC CC-ALU-DESC CC-DSP-DESC CC-JMP-DESC
473                  CC-JMP-BIT-DESC CC-JMP-ALU-DESC CC-BYT-DESC CC-DEST-DESC
474                  CC-M-DEST-DESC CC-A-DEST-DESC CC-MODE-DESC-TABLE
475                  CC-SEXP-DESC))
476
477(SETQ CC-MODE-DESC-TABLE '(
478        (H . CC-HWD-DESC) (B . CC-BYTE-DESC)
479        (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
480        (I . CC-INST-DESC) (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
481        (/# . CC-BITS-DESC)
482))
483
484
485;DESC "LANGUAGE"
486; (TYPE LITERAL)
487;       type out specified atom.  All frobs typed are followed by space.
488; (CTYPE LITERAL)
489;       same, but no separating spaces before or after, and uses PRINC.
490; (SELECT-FIELD <FIELD-NAME> <FIELD-POSITION> <SYMBOLS FOR CONSECUTIVE VALUES>)
491;       value of field selects element of list, which is symbolic name or
492;               NIL -> null typeout, and this value is the default on input.
493;               T  -> numeric typeout of value.  For values that aren't expected.
494;               A list can appear instead of a symbol, containing
495;               alternate names.  NIL can be one of them, making that value the
496;               default on input.  For type out, if NIL is present in the list
497;               then nothing is typed.  The first element of the list
498;               is used to tell you what you got if you got it as the default.
499; (TYPE-FIELD <FIELD-NAME> <FIELD-POSITION> <REGISTER-ADR OFFSET>)
500;       This is two things in one:
501;        If <REGISTER-ADR OFFSET> is NIL, then the field's contents are a number.
502;        Otherwise, <REGISTER-ADR OFFSET> should be RAAMO, RAMMO, RACMO, RAFDO, etc.
503;        and the contents are a register, which should be handled symbolically.
504; (NUM <FIELD-POSITION>)
505;       pure numeric field, prompting with "#: ".
506; (SUB-FIELD <DESCRIPTION-NAME>)
507;       call sub-description.
508; (COND <FIELD-NAME> <FIELD-POSITION> <LIST-OF-DESCRIPTIONS>)
509;       value of field selects element of list, do SUB-FIELD call to it.
510; (CONSTANT <FIELD-POSITION> <VALUE>)
511;       on type-in this constant is added in.
512; (CALL <FUNCTION> <FIELD-POSITION> . <ITEMREST>)
513;       for type-out, the function is called with 3 args.
514;       1st arg is field value.
515;       2nd arg is whole word
516;       3nd arg is <ITEMREST>.
517;       For input, <FUNCTION> should have an INPUT property which is the
518;       function to use for input.
519;       1st arg is the value accumulated so far.
520;       2nd arg is WD-BITS-SET, a mask with 1's in the bits whose values are known as yet.
521;       3rd arg is T if this is changing fields in the previous quantity.
522;       4th arg is the CDDR of the item, or (<FIELD-POSITION> . <ITEMREST>).
523; (IF-EQUAL <FIELD-NAME> <POSITION> <COMPARED-WITH> <DESC-IF-EQUAL> <DESC-IF-NOT>)
524;       This is like COND on typeout, except that it is a two way dispatch
525;       which compares a field's contents against a single distinguished value.
526;       The two DESC arguments should be desc lists or names of such.
527;       On input, if the field is already known, the appropriate branch is taken;
528;       otherwise, it is required that one of the branches be nil, and the
529;       other one is taken (always).
530; (INPUT . <DESCS>)
531;       the descriptors <DESCS> are processed only on input.
532; (OUTPUT . <DESCS>)
533;       the descriptors <DESCS> are processed only on output.
534; (BITS)  typeout only, type bit numbers of set bits.
535
536(SETQ CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
537
538(SETQ CC-BITS-DESC '( (BITS)))
539
540(SETQ CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)
541))
542
543(SETQ CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
544                      (NUM 2010) (CTYPE /,) (NUM 3010)
545))
546
547(SETQ CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
548
549
550(SETQ CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
551                   (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
552                   (SELECT-FIELD DATA-TYPE 3005
553                       (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
554                        GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
555                        HEADER-FORWARD BODY-FORWARD
556                           LOCATIVE LIST U-ENTRY FEF-POINTER
557                        ARRAY-POINTER ARRAY-HEADER STACK-GROUP CLOSURE SMALL-FLONUM
558                            SELECT-METHOD INSTANCE INSTANCE-HEADER
559                        ENTITY T T T T T T T))
560                   (NUM 0030)
561))
562
563(SETQ CC-A-DESC '( (CONSTANT 3005 2)    ;ARRAY-HEADER DATA-TYPE
564                   (SELECT-FIELD ARRAY-TYPE 2305
565                       (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q
566                        ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL
567                        ART-TVB ART-REG-PDL T T T T T T T T T T T T T T T T T T))
568                   (SELECT-FIELD HIGH-SPARE-BIT 2201 (NIL HIGH-SPARE-BIT))
569                   (SELECT-FIELD LEADER 2101 (NIL LEADER))
570                   (SELECT-FIELD DISPLACED 2001 (NIL DISPLACED))
571                   (SELECT-FIELD FLAG 1701 (NIL FLAG))
572                   (TYPE-FIELD /#DIMS 1403 NIL)
573                   (SELECT-FIELD LONG 1301 (NIL LONG))
574                   (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT))
575                   (TYPE-FIELD INDEX-LENGTH 0012 NIL)
576))
577
578(SETQ CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
579                       (CALL CALL0 MOVE CAR
580                        CDR CADR CDDR CDAR
581                        CAAR NIL NIL NIL
582                        NIL MISC T T))
583                      (COND OP-CODE 1104 (CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
584                        CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
585                        CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
586                        CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC
587                        CC-I-BR-DESC CC-I-DEST-DESC NIL NIL))
588                      (COND SUB-OP 1104 (CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
589                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
590                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
591                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
592                        NIL CC-I-15-DESC NIL NIL))
593))
594
595(SETQ CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
596                          (IGNORE STACK NEXT LAST
597                           RETURN NEXTQ LASTQ NEXT-LIST))
598))
599
600(SETQ CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
601))
602
603(SETQ CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
604
605(SETQ CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
606                          (NUM 0006)
607))
608
609(SETQ CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
610                       (BR BR-NIL BR-NOT-NIL BR-NIL-OR-POP
611                        BR-NOT-NIL-OR-POP BR-ATOM BR-NOT-ATOM T))
612                      (NUM 0011)  ;FOR NOW, DOESN'T INTERPRET BRANCH DELTA
613))
614
615(SETQ CC-I-11-DESC '( (SELECT-FIELD OP 1503
616                        (T + - * // LOGAND LOGXOR LOGIOR))
617))
618
619(SETQ CC-I-12-DESC '( (SELECT-FIELD OP 1503
620                        (= > < EQ SCDR SCDDR 1+ 1-))
621))
622
623(SETQ CC-I-13-DESC '( (SELECT-FIELD OP 1503
624                        (BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP))
625))
626
627(SETQ CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
628                      (OUTPUT (CALL CC-I-MISC-NAME 0011)) ))   
629
630(DEFUN CC-I-MISC-NAME (DISP IGNORE IGNORE)
631  (COND ((< DISP 100) (FORMAT T "LIST ~D long " DISP))
632        ((< DISP 200) (FORMAT T "LIST-IN-AREA ~D long " (- DISP 100)))
633        ((< DISP 220) (FORMAT T "UNBIND ~D bindings " (- DISP 177)))
634        ((< DISP 240) (FORMAT T "POP-PDL ~D times " (- DISP 217)))
635        (T
636          #Q (LET ((OP (MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200))))  ;uses local machine's
637               (COND (OP (FORMAT T "~A " OP)))))))                   ; context.
638
639;_V microinstruction type-out and type-in,
640;for use in hardware debugging.  In CADRD.
641
642;Functions used by the descriptors for _U output and input.
643
644;(CALL CC-BYTE-FIELD-OUT 00nn always-reflect-mrot length-is-minus-one)
645;nn should be 05 for a jump insn where the length minus one is zero.
646;nn it is 12 for a byte insn which has 5 bits of mrot and 5 bits of length minus one.
647(DEFPROP CC-BYTE-FIELD-OUT CC-BYTE-FIELD-IN INPUT)
648(DEFUN CC-BYTE-FIELD-OUT (VAL WD ITEMREST)
649    (PRINC '|(BYTE-FIELD |)
650    (PRIN1-THEN-SPACE
651       (COND ((CADR ITEMREST)
652              (1+ (LOGLDB 0505 VAL)))
653             (T (LOGLDB 0505 VAL))))
654    (LET ((TEM (LOGLDB 0005 VAL)))
655         (COND ((ZEROP TEM))
656               ((OR (CAR ITEMREST) (= 1 (LOGLDB 1402 WD)))
657                (SETQ TEM (- 32. TEM))))
658         (PRIN1 TEM))
659    (PRINC '|) |))
660
661(DEFUN CC-BYTE-FIELD-IN (WD WD-BITS-SET TYPE-OVER ITEMREST)
662  (PROG (TEM)
663    (PRINC '|(BYTE-FIELD |)
664    (COND ((= (CAR ITEMREST) 0005) (PRINC '|WIDTH 1 |))
665          (T
666           (SETQ TEM (LOGLDB 0505 (LOGLDB (CAR ITEMREST) WD)))
667           (AND (CADDR ITEMREST) (SETQ TEM (1+ TEM)))
668           (SETQ TEM (CC-TYPE-IN '((TYPE-FIELD WIDTH 0006 NIL))
669                                 (COND (TYPE-OVER
670                                        TEM)
671                                       (T 0))
672                                 TYPE-OVER))
673           (TYO 10) (TYO 10) (TYO 10) (TYO 10)
674           (AND (CADDR ITEMREST) (SETQ TEM (1- TEM)))
675           (SETQ WD (LOGDPB (LOGLDB (CAR ITEMREST) (LOGDPB TEM 0505 WD))
676                            (CAR ITEMREST) WD))
677           (SETQ WD-BITS-SET (LOGDPB (LOGLDB (CAR ITEMREST) (LOGDPB -1 0505 WD-BITS-SET))
678                                     (CAR ITEMREST) WD-BITS-SET))))
679    (SETQ TEM (CC-TYPE-IN '((TYPE-FIELD POSITION 0005 NIL))
680                          (COND ((NOT TYPE-OVER) 0)
681                                ((OR (CADR ITEMREST) (= 1 (LOGLDB 1402 WD)))
682                                 (LOGAND 37 (- 40 (LOGLDB 0005 WD))))
683                                (T (LOGLDB 0005 WD)))
684                          TYPE-OVER))
685    (TYO 10) (TYO 10) (TYO 10) (TYO 10)
686   
687    (COND ((OR (CADR ITEMREST) (= 1 (LOGLDB 1402 WD)))
688           (SETQ TEM (- 32. TEM))))
689    (SETQ WD (LOGDPB TEM 0005 WD))
690    (SETQ WD-BITS-SET (LOGDPB -1 0005 WD-BITS-SET))
691    (PRINC '|) |)
692    (RETURN (LIST WD WD-BITS-SET))))
693
694(DEFUN CC-TYPE-JUMP-CONDITION (NUMBER IGNORE1 IGNORE2)
695  IGNORE1 IGNORE2
696  (PROG (TEM)
697    (PRINC (NTH (LSH (LOGAND 1400 NUMBER) -10) '(JUMP CALL POPJ CALL-POPJ-??)))
698    (COND ((ZEROP (LOGAND 40 NUMBER))
699           (PRINC '|-IF-BIT-|)
700           (COND ((ZEROP (LOGAND 100 NUMBER))
701                  (PRINC 'SET))
702                 (T (PRINC 'CLEAR)))
703           (COND ((ZEROP (LOGAND 200 NUMBER))
704                  (PRINC '|-XCT-NEXT|)))
705           (PRINC '| (BYTE-FIELD 1 |)
706           (PRIN1 (- 32. (LOGAND 37 NUMBER)))
707           (PRINC '|)|))
708          (T
709           (SETQ TEM (NTH (COND ((ZEROP (LOGAND 100 NUMBER)) (LOGAND 7 NUMBER))
710                                (T (+ 10 (LOGAND 7 NUMBER))))
711                          '(T -LESS-THAN -LESS-OR-EQUAL -EQUAL
712                              -IF-PAGE-FAULT -IF-PAGE-FAULT-OR-INTERRUPT
713                              -IF-SEQUENCE-BREAK NIL
714                              T -GREATER-OR-EQUAL -GREATER-THAN -NOT-EQUAL
715                              -IF-NO-PAGE-FAULT -IF-NO-PAGE-FAULT-OR-INTERRUPT
716                              -IF-NO-SEQUENCE-BREAK -NEVER)))
717           (COND ((EQ TEM T)
718                  (COND ((ZEROP (LOGAND 200 NUMBER))
719                         (PRINC '|-XCT-NEXT|)))
720                  (PRINC '| JUMP-CONDITION |) (PRIN1 (LOGAND 7 NUMBER))
721                  (OR (ZEROP (LOGAND 100 NUMBER))
722                      (PRINC '| (INVERTED)|)))
723                 (T
724                  (AND TEM (PRINC TEM))
725                  (COND ((ZEROP (LOGAND 200 NUMBER))
726                         (PRINC '|-XCT-NEXT|)))))))
727    (PRINC '/ )))
728
729(DECLARE (SPECIAL ART-STRING %FEFHI-FCTN-NAME
730                  Q-DATA-TYPES CC-SEXP-PRINLEVEL CC-SEXP-PRINLENGTH
731                  %%ARRAY-TYPE-FIELD))
732
733(DEFUN CC-Q-PRINT-TOPLEV-1 (TYPED-POINTER WD ITEMREST)
734    WD ITEMREST
735    (CC-Q-PRINT TYPED-POINTER CC-SEXP-PRINLEVEL))
736
737(DECLARE (SPECIAL SI:*IOLST SI:*IOCH))
738
739(DEFUN CC-Q-EXPLODE (X &AUX (SI:*IOLST NIL) (SI:*IOCH T))
740  (LET ((CC-OUTPUT-STREAM (FUNCTION SI:EXPLODE-STREAM)))
741    (CC-Q-PRINT-TOPLEV X))
742  (NREVERSE SI:*IOLST))
743
744(DEFUN CC-Q-PRINT-TOPLEV (TYPED-POINTER)
745    (CC-Q-PRINT TYPED-POINTER CC-SEXP-PRINLEVEL))
746
747(COND ((NULL (BOUNDP 'CC-SEXP-PRINLEVEL))
748        (SETQ CC-SEXP-PRINLEVEL 20)))
749
750(COND ((NULL (BOUNDP 'CC-SEXP-PRINLENGTH))
751        (SETQ CC-SEXP-PRINLENGTH 100)))
752
753(DEFUN CC-Q-PRINT (TYPED-POINTER I-PRINLEVEL)
754  (PROG (PRINLENGTH-COUNT DATA-TYPE Q-POINTER HEADER TEM)
755        (SETQ PRINLENGTH-COUNT 0)
756        (SETQ DATA-TYPE (LOGLDB %%Q-DATA-TYPE TYPED-POINTER))
757        (SETQ Q-POINTER (LOGLDB %%Q-POINTER TYPED-POINTER))
758        (COND ((CC-Q-ATOM TYPED-POINTER)
759               (COND ((= DATA-TYPE DTP-SYMBOL)
760                      (RETURN (CC-Q-PRINT-STRING (CC-MEM-READ Q-POINTER))))
761                     ((= DATA-TYPE DTP-FIX)
762                      (RETURN (CC-Q-PRINT-FIX Q-POINTER)))
763                     (T (GO BOMB))))
764              ((= DATA-TYPE DTP-STACK-GROUP)
765               (PRINC '|<Stack Group |)
766               (SETQ TEM (QF-ARRAY-LEADER (QF-MAKE-Q (QF-POINTER TYPED-POINTER)
767                                                     DTP-ARRAY-POINTER)
768                                          SG-NAME)
769                     DATA-TYPE (LOGLDB %%Q-DATA-TYPE TEM))
770               (COND ((= DATA-TYPE DTP-ARRAY-POINTER)) ;a string?
771                     ((= DATA-TYPE DTP-SYMBOL)
772                      (SETQ TEM (CC-MEM-READ TEM))) ;get-pname
773                     (T (ERROR '|SG name has a bad type -- CC-Q-PRINT|)))
774               (CC-Q-PRINT-STRING TEM)
775               (PRINC '|>|)
776               (RETURN NIL))
777              ((= DATA-TYPE DTP-ARRAY-POINTER)
778               (SETQ HEADER (CC-MEM-READ Q-POINTER)) ;get array header following forwarding ptr
779               (COND ((= (MASK-FIELD-FROM-FIXNUM %%ARRAY-TYPE-FIELD HEADER)
780                         ART-STRING)
781                      (PRINC '/")
782                      (CC-Q-PRINT-STRING Q-POINTER)
783                      (PRINC '/")
784                      (RETURN NIL))
785                     ((NOT (ZEROP (MASK-FIELD-FROM-FIXNUM %%ARRAY-NAMED-STRUCTURE-FLAG
786                                                          HEADER)))
787                      ;; The array is a named-structure.
788                      (LET ((NSS NIL) (NAME NIL))
789                        (COND ((NOT (ZEROP (MASK-FIELD-FROM-FIXNUM
790                                            %%ARRAY-LEADER-BIT HEADER)))
791                               (SETQ NSS (QF-ARRAY-LEADER TYPED-POINTER 1))
792                               (SETQ NAME (QF-ARRAY-LEADER TYPED-POINTER 2)))
793                              (T (SETQ NSS (QF-AR-1 TYPED-POINTER 0))
794                                 (SETQ NAME (QF-AR-1 TYPED-POINTER 1))))
795                        (PRINC '|#<|)
796                        (CC-Q-PRINT NSS I-PRINLEVEL)
797                        (PRINC '| |)
798                        (CC-Q-PRINT NAME I-PRINLEVEL)
799                        (PRINC '| |)
800                        (PRIN1 (LOGLDB %%Q-POINTER TYPED-POINTER))
801                        (PRINC '|>|))
802                      (RETURN NIL))
803                     (T (GO BOMB))))
804              ((= DATA-TYPE DTP-U-ENTRY)
805               (RETURN (CC-Q-PRINT-U-ENTRY TYPED-POINTER I-PRINLEVEL)))
806              ((= DATA-TYPE DTP-FEF-POINTER)
807               (RETURN (CC-Q-PRINT-FRAME TYPED-POINTER I-PRINLEVEL)))
808              ((NOT (= DATA-TYPE DTP-LIST))
809               (GO BOMB))
810              ((= I-PRINLEVEL 0)
811               (PRINC '/#)
812               (RETURN NIL)))
813        (PRINC '/()
814    L   (CC-Q-PRINT (QF-CAR TYPED-POINTER) (1- I-PRINLEVEL))
815        (SETQ TYPED-POINTER (QF-CDR TYPED-POINTER))
816        (COND ((CC-Q-NULL TYPED-POINTER)
817               (PRINC '/))
818               (RETURN NIL)))
819        (PRINC '/ )
820        (COND ((NOT (= DTP-LIST (SETQ DATA-TYPE (LOGLDB %%Q-DATA-TYPE TYPED-POINTER))))
821               (PRINC '/./ )
822               (CC-Q-PRINT TYPED-POINTER (1- I-PRINLEVEL))
823               (PRINC '/))
824               (RETURN NIL))
825              ((> (SETQ PRINLENGTH-COUNT (1+ PRINLENGTH-COUNT)) CC-SEXP-PRINLENGTH)
826               (PRINC '/./././))
827               (RETURN NIL)))
828        (GO L)
829
830   BOMB (RETURN (CC-Q-PRINT-BOMB TYPED-POINTER))
831))
832
833;;;*** This knows that NIL is at location zero.
834(DEFUN CC-Q-NULL (TYPED-POINTER)
835   (COND ((AND (= 0 (LOGLDB %%Q-POINTER TYPED-POINTER))
836               (= (LOGLDB %%Q-DATA-TYPE TYPED-POINTER)
837                   DTP-SYMBOL))
838            T)))
839
840(DEFUN CC-Q-ATOM (TYPED-POINTER)
841  (PROG (DATA-TYPE)
842        (SETQ DATA-TYPE (LOGLDB %%Q-DATA-TYPE TYPED-POINTER))
843        (COND ((OR (= DATA-TYPE DTP-SYMBOL)
844                   (= DATA-TYPE DTP-FIX)
845                   (= DATA-TYPE DTP-EXTENDED-NUMBER))
846                (RETURN T)))
847        (RETURN NIL)))
848
849(DEFUN CC-Q-PRINT-FIX (Q-NUM)
850  (COND ((NOT (ZEROP (LOGLDB 2701 Q-NUM)))
851          (SETQ Q-NUM #M (BOOLE 15 Q-NUM 77777777)
852                      #Q (%LOGDPB 1 2701 (LDB 0027 Q-NUM)))))
853  (PRIN1 Q-NUM))
854
855(DECLARE (SPECIAL QF-ARRAY-DATA-ORIGIN QF-ARRAY-LENGTH
856                  QF-ARRAY-HAS-LEADER-P QF-ARRAY-HEADER-ADDRESS))
857
858;;; Print a string.  Note that it is truncated to at most 200 characters to
859;;; avoid printing infinite garbage
860(DEFUN CC-Q-PRINT-STRING (ADR)
861  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER))
862  (DO ((LEN (COND (QF-ARRAY-HAS-LEADER-P
863                   (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
864                  (T QF-ARRAY-LENGTH)))
865       (ADR QF-ARRAY-DATA-ORIGIN)
866       (I 0 (1+ I))
867       (CH)
868       (WD))
869      ((OR (>= I LEN) (= I 200))
870       (AND (< I LEN) (PRINC '/././.) CC-OUTPUT-STREAM)
871       NIL)
872    (DECLARE (FIXNUM LEN ADR I WD))
873    (COND ((ZEROP (LOGAND 3 I)) ;Get next word
874           (SETQ WD (QF-MEM-READ ADR)
875                 ADR (1+ ADR))))
876    (SETQ CH (LOGAND 377 WD)
877          WD (CC-SHIFT WD -8))
878    (TYO CH CC-OUTPUT-STREAM))) ;On the pdp10, should check for format-effectors
879               
880(DEFUN CC-Q-PRINT-U-ENTRY (TYPED-POINTER I-PRINLEVEL)
881  (PROG (TEM)
882        (SETQ TEM (QF-INITIAL-AREA-ORIGIN 'MICRO-CODE-ENTRY-NAME-AREA))
883        (COND ((= TEM 0)
884                (RETURN (CC-Q-PRINT-BOMB TYPED-POINTER))))
885        (PRIN1-THEN-SPACE 'DTP-U-ENTRY)
886        (CC-Q-PRINT (QF-MEM-READ (+ TEM (LOGLDB %%Q-POINTER TYPED-POINTER))) I-PRINLEVEL)))
887
888(DEFUN CC-Q-PRINT-FRAME (TYPED-POINTER I-PRINLEVEL)
889  (PROG (TEM)
890        (SETQ TEM (CC-MEM-READ (+ %FEFHI-FCTN-NAME (LOGLDB %%Q-POINTER TYPED-POINTER))))
891        (PRINC '/#/<DTP-FEF-POINTER/ )
892        (CC-Q-PRINT TEM I-PRINLEVEL)
893        (PRINC '/ )
894        (PRIN1 (QF-POINTER TYPED-POINTER))
895        (PRINC '/>)))
896
897(DEFUN CC-Q-PRINT-BOMB (TYPED-POINTER)
898  (PROG (DATA-TYPE Q-POINTER)
899        (SETQ DATA-TYPE (LOGLDB %%Q-DATA-TYPE TYPED-POINTER))
900        (SETQ Q-POINTER (LOGLDB %%Q-POINTER TYPED-POINTER))
901        (PRINC '/#<)
902        (PRIN1 (NTH DATA-TYPE Q-DATA-TYPES))
903        (PRINC '/ )
904        (PRIN1 Q-POINTER)
905        (COND ((= DATA-TYPE DTP-NULL)
906               (TYO 40)
907               (CC-Q-PRINT-STRING (CC-MEM-READ TYPED-POINTER)))
908              ((= DATA-TYPE DTP-SYMBOL-HEADER)
909               (TYO 40)
910               (CC-Q-PRINT-STRING TYPED-POINTER))
911              ((= DATA-TYPE DTP-FEF-POINTER)
912               (TYO 40)
913               (CC-Q-PRINT-STRING (CC-MEM-READ (+ %FEFHI-FCTN-NAME TYPED-POINTER)))))
914        (PRIN1 '>)
915        (RETURN T)))
916
917(DEFUN CC-MEM-READ (ADDR)
918    (DO ((X (QF-MEM-READ ADDR) (QF-MEM-READ ADDR))
919         (DTP))
920        (NIL)
921      (SETQ DTP (QF-DATA-TYPE X))
922      (COND ((= DTP DTP-BODY-FORWARD)
923             (LET ((OFFSET (- (QF-POINTER ADDR) (QF-POINTER X))))
924               (SETQ X (+ (QF-MEM-READ X) OFFSET))))
925            ((OR (= DTP DTP-HEADER-FORWARD)
926                 (= DTP DTP-ONE-Q-FORWARD)
927                 (= DTP DTP-EXTERNAL-VALUE-CELL-POINTER))) ;loop
928            (T (RETURN X)))
929      (SETQ ADDR X)))
930
931(DEFUN CC-TYPE-OUT (WD DESC PROMPTP *DONT-TOUCH-MACHINE*)
932  (PROG (DC ITEM VAL TEM SYM-BASE)
933        (SETQ DC (COND ((ATOM DESC) (SYMEVAL DESC))
934                       (T DESC)))
935    L   (COND ((NULL DC) (RETURN T)))
936        (SETQ ITEM (CAR DC))
937        (COND ((EQ (CAR ITEM) 'TYPE-FIELD)
938                (GO T-F))
939              ((EQ (CAR ITEM) 'SELECT-FIELD)
940               (SETQ VAL (LOGLDB (CADDR ITEM) WD))
941               (SETQ TEM (NTH VAL (CADDDR ITEM)))
942               (OR (ATOM TEM)
943                   (SETQ TEM (COND (PROMPTP (AND (CADR TEM) (CAR TEM)))
944                                   (T (CAR TEM)))))
945               (COND ((NULL TEM))
946                     ((EQ TEM T)
947                       (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
948                       (PRIN1-THEN-SPACE (LOGLDB (CADDR ITEM) WD)))
949                     (T(AND (EQ PROMPTP 'ALL) (PRIN1-THEN-SPACE (CADR ITEM)))
950                       (PRIN1-THEN-SPACE TEM))))
951              ((EQ (CAR ITEM) 'SUB-FIELD)
952                (CC-TYPE-OUT WD (CADR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
953              ((EQ (CAR ITEM) 'COND)
954                (GO COND))
955              ((EQ (CAR ITEM) 'IF-EQUAL)
956               (SETQ TEM (CDDDDR ITEM))
957               (COND ((NOT (= (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM)))
958                      (SETQ TEM (CDR TEM))))
959               (AND (CAR TEM)
960                    (CC-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)))
961              ((EQ (CAR ITEM) 'CALL)
962                (FUNCALL (CADR ITEM) (LOGLDB (CADDR ITEM) WD) WD (CDDDR ITEM)))
963              ((EQ (CAR ITEM) 'TYPE)
964                (PRIN1-THEN-SPACE (CADR ITEM)))
965              ((EQ (CAR ITEM) 'CTYPE)
966                (TYO 10)
967                (PRINC (CADR ITEM)))
968              ((EQ (CAR ITEM) 'NUM)
969                (PRIN1-THEN-SPACE (LOGLDB (CADR ITEM) WD)))
970              ((EQ (CAR ITEM) 'CONSTANT))
971              ((EQ (CAR ITEM) 'INPUT))
972              ((EQ (CAR ITEM) 'OUTPUT)
973               (CC-TYPE-OUT WD (CDR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
974              ((EQ (CAR ITEM) 'BITS)
975               (CC-PRINT-BITS WD))
976              (T (PRINT (LIST (CAR ITEM) 'IN ITEM  'UNKNOWN-DESCRIPTOR))))
977    L1  (SETQ DC (CDR DC))
978        (GO L)
979
980  T-F   (SETQ VAL (LOGLDB (CADDR ITEM) WD))
981        (COND ((NULL (CADDDR ITEM))                     ;3RD ARG IS NIL - PRINT NUMBER.
982               (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
983               (PRIN1-THEN-SPACE VAL)
984               (GO L1)))
985        (SETQ SYM-BASE (SYMEVAL (CADDDR ITEM)))
986        (COND ((MEMQ (CADDDR ITEM) '(RACMO RADMO))
987               (CC-C-OR-D-ADR-OUT (CADR ITEM) VAL SYM-BASE))
988              (T (CC-A-OR-M-ADR-OUT (CADR ITEM) VAL SYM-BASE)))
989        (GO L1)
990
991  COND  (SETQ VAL (LOGLDB (CADDR ITEM) WD))
992        (SETQ TEM (CADDDR ITEM))
993  C-1   (COND ((NULL TEM) (GO L1))
994              ((= VAL 0) (GO C-2)))
995        (SETQ TEM (CDR TEM))
996        (SETQ VAL (1- VAL))
997        (GO C-1)
998  C-2   (CC-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)
999        (GO L1)
1000))
1001
1002(DEFUN CC-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE)
1003    TYPE
1004    (PRIN1-THEN-SPACE (OR (CC-FIND-CLOSEST-SYM (+ SYM-BASE VAL)) VAL)))
1005
1006(DEFUN CC-A-OR-M-ADR-OUT (TYPE VAL SYM-BASE)
1007    (PROG (TEM)
1008        (COND ((ZEROP VAL) (RETURN NIL))
1009              ((OR (AND (SETQ TEM (CC-FIND-CLOSEST-SYM (+ SYM-BASE VAL)))
1010                        (ATOM TEM))
1011                   *DONT-TOUCH-MACHINE*)
1012               (COND ((NULL TEM)
1013                      (FORMAT T "~S@A" VAL))
1014                     (T
1015                      (PRIN1 TEM))))
1016              (T
1017               (PRIN1 VAL)
1018               (PRINC '/@)
1019               (PRINC TYPE)
1020               (PRINC '/[)
1021               (PRIN1 (CC-REGISTER-EXAMINE (+ VAL SYM-BASE)))
1022               (PRINC '/])))
1023        (PRINC '/ )))
1024
1025(IF-FOR-MACLISP
1026(DEFUN PRIN1-THEN-SPACE (X)
1027      (PRIN1 X)
1028      (PRINC '/ )))
1029
1030(DEFUN TYI-UPPERCASIFY NIL
1031  (PROG (CH)
1032        (SETQ CH (TYI CC-INPUT-STREAM))
1033        (COND ((AND (NOT (< CH 141))
1034                    (NOT (> CH 172)))
1035               (SETQ CH (- CH 40))))
1036        (RETURN CH)))
1037
1038(DEFUN CC-TYPE-IN (DESC WD TYPE-OVER)
1039 (PROG (DESC-STACK SYL N TEM CH ITEM WD-BITS-SET)
1040  (PRINC '/ )
1041  (SETQ WD-BITS-SET 0)          ;MASK FOR BITS SET THIS TIME AROUND
1042A (AND (ATOM DESC) (SETQ DESC (SYMEVAL DESC)))
1043B (SETQ ITEM '(OUTPUT))
1044  (CC-TI-CONTROL-SEQUENCE)
1045AA
1046  (COND ((NULL ITEM)
1047         (PRINC '|   |)
1048         (RETURN WD)))
1049  ;;DEAL WITH STANDARD CONTROL-SEQUENCE DESCRIPTORS IN STANDARD WAY.
1050  (AND (CC-TI-CONTROL-SEQUENCE) (GO AA))
1051  ;MAYBE THIS DESCRIPTION ITEM DOESN'T CALL FOR TYPE-IN?  OR NEEDS PROMPT
1052  (COND ((EQ (CAR ITEM) 'CONSTANT)
1053         (SETQ WD (PLUS WD (LOGDPB (CADDR ITEM) (CADR ITEM) 0)))
1054         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET))
1055         (GO B))
1056        ((EQ (CAR ITEM) 'CALL)
1057         (COND ((SETQ CH (GET (CADR ITEM) 'INPUT))
1058                (SETQ CH (FUNCALL CH WD WD-BITS-SET TYPE-OVER (CDDR ITEM)))
1059                (SETQ WD (CAR CH) WD-BITS-SET (CADR CH))
1060                (GO B))
1061               (T (PRINC '|I can't hack this |)
1062                  (RETURN NIL))))
1063        ;; We require that an IF-EQUAL either be determined from bits already set
1064        ;; or have only one non-empty alternative (which we always take).
1065        ((EQ (CAR ITEM) 'IF-EQUAL)
1066          (PUSH DESC DESC-STACK)
1067          (COND ((NOT (ZEROP (LOGLDB (CADDR ITEM) WD-BITS-SET)))
1068                 (SETQ DESC (COND ((= (CADDDR ITEM) (LOGLDB (CADDR ITEM) WD))
1069                                   (CAR (CDDDDR ITEM)))
1070                                  (T (CADR (CDDDDR ITEM))))))
1071                ((NULL (CAR (CDDDDR ITEM)))
1072                 (SETQ DESC (CADR (CDDDDR ITEM))))
1073                ((NULL (CADR (CDDDDR ITEM)))
1074                 (SETQ DESC (CAR (CDDDDR ITEM))))
1075                (T (BREAK 'BAD-IF-EQUAL-DESC-FOR-INPUT)))
1076          (GO B))
1077        ((AND (EQ (CAR ITEM) 'COND)     ;COND THAT DEPENDS ON PREVIOUS TYPE-IN
1078              (NOT (ZEROP (LOGLDB (CADDR ITEM) WD-BITS-SET))))
1079         (SETQ ITEM `(SUB-FIELD ,(NTH (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM))))
1080         (CC-TI-CONTROL-SEQUENCE)
1081         (GO AA))
1082        ((MEMQ (CAR ITEM) '(SELECT-FIELD TYPE-FIELD COND))
1083         (PRIN1-THEN-SPACE (CADR ITEM)))
1084        ((EQ (CAR ITEM) 'NUM)
1085         (PRINC '|#: |)))
1086  (SETQ SYL NIL)
1087
1088  ;ITEM IS A DESCRIPTOR, SYL HAS TYPE-IN SO FAR.
1089  ;HERE TO READ MORE.
1090C (COND (CC-LOW-LEVEL-FLAG (CC-REPLACE-STATE)))
1091  (SETQ CH (TYI-UPPERCASIFY))
1092  (COND ((OR (= CH 77) (= CH 40) (= CH 33)) (GO D))
1093        ((< CH 40)
1094         (TERPRI)
1095         (MAPC 'TYO SYL))
1096        ((= CH 177)
1097         (OR SYL (RETURN (PROGN (PRINC '|??  |) NIL)))
1098         (SETQ SYL (NREVERSE (CDR (NREVERSE SYL))))
1099         (CURSORPOS 'X))
1100        ((NULL SYL) (SETQ SYL (LIST CH)))
1101        ((RPLACD (LAST SYL) (LIST CH))))
1102  (GO C)
1103
1104  ;HAVE SOME TYPE-IN, CH HAS DELIMITER.
1105  D
1106  (COND ((AND TYPE-OVER (= CH 40) (NULL SYL))
1107         (GO K)))
1108 
1109  ;FIRST SET TEM TO LIST OF POSSIBLE COMPLETIONS
1110  (SETQ TEM (ELIMINATE-DUPLICATES (CC-TI-POSSIBILITIES SYL ITEM)))
1111  (COND ((NULL TEM)
1112         (PRINC '-IMPOSS-))
1113        ((= CH 77)
1114         (MAPC 'PRIN1-THEN-SPACE TEM))
1115        ((= CH 33)
1116         (GO F))
1117        ((COND ((NULL SYL)              ;CHECK FOR AMBIGUITY,
1118                (NOT (MEMQ NIL TEM)))   ;HACKING DEFAULT AND EXACT-MATCH
1119               ((AND (> (LENGTH TEM) 1)
1120                     (NOT (AND (MEMQ (SETQ CH (READLIST SYL)) TEM)
1121                               (SETQ TEM (CONS CH TEM)))) )))
1122         (PRINC '-AMBIG-))
1123        ((GO H)))
1124  ;RETYPE THE SYLLABLE AND READ MORE.
1125  (MAPC 'TYO SYL)
1126  (GO C)
1127
1128  ;HERE TO DO COMPLETION, SYL HAS LIST OF CHARS TYPED SO FAR,
1129  ;TEM HAS LIST OF POSSIBILITIES, TYPE OUT ALL CHARS THAT ARE FORCED.
1130F (CURSORPOS 'X)        ;UNECHO THE ALTMODE
1131  (AND (NUMBERP (CAR TEM))
1132       (GO C))          ;CAN'T COMPLETE PURE-NUMERIC TYPEIN
1133G (SETQ N (1+ (LENGTH SYL))) ;INDEX OF CHAR TO LOOK AT
1134  (SETQ CH (GETCHARN (CAR TEM) N))
1135  (AND (= CH 0) (GO C))
1136  ;CH HAS PROPOSED CHARACTER, SEE IF ALL POSSIBILITIES AGREE
1137  (AND (DO TEM (CDR TEM) (CDR TEM) (NULL TEM)
1138        (OR (= CH (GETCHARN (CAR TEM) N))
1139            (RETURN T)))
1140       (GO C))          ;DISAGREEMENT, STOP HERE
1141  (TYO CH)
1142  (COND ((NULL SYL) (SETQ SYL (LIST CH)))
1143        ((RPLACD (LAST SYL) (LIST CH))))
1144  (GO G)
1145
1146  ;TYPEIN HAS BEEN COMPLETED AND ACCEPTED, DIGEST IT.
1147H (SETQ TEM (AND SYL (CAR TEM)))
1148  (CURSORPOS 'B)        ;UNSPACE
1149  (OR (NUMBERP TEM)
1150      (NULL SYL)
1151      (DO ((CH)         ;DO FINAL STAGE OF COMPLETION
1152           (N (1+ (LENGTH SYL)) (1+ N)))
1153          (NIL)
1154        (AND (= 0 (SETQ CH (GETCHARN TEM N)))
1155             (RETURN NIL))
1156        (TYO CH)))
1157  (PRINC '/ )           ;SPACE AFTER FIELD
1158I (COND ((EQ (CAR ITEM) 'TYPE))
1159        ((EQ (CAR ITEM) 'SELECT-FIELD)
1160         (SETQ TEM (COND ((NUMBERP TEM) TEM)
1161                         ((AND (NULL SYL)
1162                               (MEMQ NIL (CDR (MEMQ NIL (CADDDR ITEM)))))
1163                          (GO B))               ;MULTIPLE NILS, DEFER DECISION
1164                         ((DO ((L (CADDDR ITEM) (CDR L)) (I 0 (1+ I))) ((NULL L) NIL)
1165                             (AND (OR (EQ (CAR L) TEM)
1166                                      (AND (NOT (ATOM (CAR L))) (MEMQ TEM (CAR L))))
1167                                  (RETURN I))))))
1168         (SETQ WD (LOGDPB TEM (CADDR ITEM) WD))
1169         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1170        ((EQ (CAR ITEM) 'TYPE-FIELD)
1171         (SETQ TEM (COND ((NUMBERP TEM) TEM)
1172                         ((NULL TEM) 0)
1173                         ((DIFFERENCE (CC-LOOKUP-NAME TEM)
1174                                      (SYMEVAL (CADDDR ITEM))))))
1175         (SETQ WD (LOGDPB TEM (CADDR ITEM) WD))
1176         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1177        ((EQ (CAR ITEM) 'NUM)
1178         (SETQ WD (LOGDPB TEM (CADR ITEM) WD))
1179         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET)))
1180        ((EQ (CAR ITEM) 'COND)
1181         (DO ((DL (CADDDR ITEM) (CDR DL))
1182              (N 0 (1+ N)))
1183             ((NULL DL) (BREAK COND-BARF T))
1184            (SETQ CH `(SUB-FIELD ,(CAR DL)))
1185            (COND ((MEMQ TEM (CC-TI-POSSIBILITIES SYL CH))
1186                   (SETQ WD (LOGDPB N (CADDR ITEM) WD))
1187                   (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET))
1188                   (RETURN NIL))))
1189         (SETQ ITEM CH)
1190         (CC-TI-CONTROL-SEQUENCE)
1191         (GO I))
1192        ((CC-TI-CONTROL-SEQUENCE) (GO I))
1193        (T (BREAK INPUT-LOSSAGE-GOBBLING)))
1194  (PRINC '/ )
1195  (GO B)
1196
1197  ;LEAVE THIS FIELD WITH SAME VALUE AS BEFORE
1198K (TYO 10)     ;Don't leave two spaces on the screen.
1199KK
1200  (COND ((EQ (CAR ITEM) 'TYPE))
1201        ((MEMQ (CAR ITEM) '(SELECT-FIELD TYPE-FIELD))
1202         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1203        ((EQ (CAR ITEM) 'NUM)
1204         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET)))
1205        ((EQ (CAR ITEM) 'COND)
1206         (SETQ ITEM `(SUB-FIELD ,(NTH (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM))))
1207         (CC-TI-CONTROL-SEQUENCE)
1208         (GO KK))
1209        ((CC-TI-CONTROL-SEQUENCE)
1210         (GO KK))
1211        (T (BREAK INPUT-LOSSAGE-SPACE)))
1212  (CC-TYPE-OUT WD (LIST ITEM) NIL NIL) ;RE-TYPE THE THING
1213  (PRINC '/ )
1214  (GO B)
1215))
1216
1217(DEFUN CC-TI-CONTROL-SEQUENCE ()
1218  (PROG ()
1219    (SELECTQ (CAR ITEM)
1220        ((SUB-FIELD INPUT)
1221          (PUSH DESC DESC-STACK)
1222          (SETQ DESC (COND ((EQ (CAR ITEM) 'INPUT) (CDR ITEM)) (T (CADR ITEM)))))
1223        (OUTPUT)
1224        (CTYPE
1225          (TYO 10)
1226          (PRINC (CADR ITEM)))
1227        (OTHERWISE (RETURN NIL)))
1228    LOOP
1229    (COND ((AND DESC (ATOM DESC))
1230           (SETQ DESC (SYMEVAL DESC))
1231           (GO LOOP))
1232          (DESC)
1233          (DESC-STACK (SETQ DESC (POP DESC-STACK))
1234                      (GO LOOP)))
1235    (SETQ ITEM (POP DESC))
1236    (RETURN T)))
1237
1238;Given a desc item ITEM, and given DESC and DESC-STACK as they are,
1239;compute the matches of the list of characters SYL against ITEM or the
1240;items that follow it/are called by it.
1241(DEFUN CC-TI-POSSIBILITIES (SYL ITEM)
1242  (LET ((DESC DESC) (DESC-STACK DESC-STACK))
1243     (PROG ()
1244         LOOP
1245         (RETURN (COND
1246               ((CC-TI-CONTROL-SEQUENCE) (GO LOOP))
1247               ((AND SYL (EVERY SYL '(LAMBDA (CH) (AND (> CH 57) (< CH 72)))))
1248                (LIST (READLIST SYL)))  ;IT IS, ONLY POSSIBILITY IS THAT NUMBER
1249               ((EQ (CAR ITEM) 'TYPE)
1250                (AND (CC-TI-MATCH SYL (CADR ITEM)) (CDR ITEM)))
1251               ((EQ (CAR ITEM) 'SELECT-FIELD)
1252                (CC-TI-SELECT-FIELD-POSSIBILITIES SYL (CADDDR ITEM)))
1253               ((EQ (CAR ITEM) 'NUM)
1254                NIL)    ;ONLY NUMBERS ALLOWED?
1255               ((EQ (CAR ITEM) 'TYPE-FIELD)
1256                (COND ((NULL (CADDDR ITEM)) NIL) ;ONLY NUMBERS ALLOWED?
1257                      ((NULL SYL)
1258                       (LIST NIL (IMPLODE (APPEND (EXPLODE (CADR ITEM)) '(- M E M - A D R)))))
1259                      (T        ;HACK COMPLETIONS OF REGISTER ADDRESSES
1260                       (LET ((FROM-I 0) (TO-I 0))
1261                            (COND ((NULL SYL)
1262                                   (SETQ FROM-I 0 TO-I CC-SYMBOLS-SIZE))
1263                                  (T (LET ((SYL+1 (APPEND SYL NIL)))
1264                                          (LET ((L (LAST SYL+1)))
1265                                               (RPLACA L (1+ (CAR L))))
1266                                          (SETQ FROM-I (CC-FIND-NAME (IMPLODE SYL))
1267                                                TO-I (CC-FIND-NAME (IMPLODE SYL+1))))))
1268                            (DO ((I FROM-I (1+ I))
1269                                 (ANS NIL))
1270                                ((NOT (< I TO-I)) (NREVERSE ANS))
1271                                (LET ((E (ARRAYCALL T CC-SYMBOLS-NAME I)))
1272                                     (AND (CC-ADR-CLOSE-ENOUGH
1273                                           (CADDDR ITEM)
1274                                           (GET (CC-FIND-REG-ADR-RANGE (CDR E))
1275                                                'CC-LOWEST-ADR))
1276                                          (SETQ ANS (CONS (CAR E) ANS))))))
1277                       )))
1278               ((EQ (CAR ITEM) 'COND)   ;HAIR....
1279                (PUSH DESC DESC-STACK)
1280                (MAPCAN (FUNCTION (LAMBDA (DESC)
1281                            (AND (ATOM DESC) (SETQ DESC (SYMEVAL DESC)))
1282                            (COND ((NULL DESC) NIL)
1283                                  ((APPEND (CC-TI-POSSIBILITIES SYL (POP DESC)) NIL)))))
1284                        (CADDDR ITEM)))
1285               (T
1286                 #Q (LOCAL-DECLARE ((SPECIAL ARGS))
1287                      ((LAMBDA (ARGS) (BREAK CC-TI-POSSIBILITIES-LOSES T))
1288                       ITEM))
1289                 #M (BREAK FUCKUP) ))))))
1290
1291;Find the possible matches for SYL in a symbol or list of symbols or lists of ...
1292(DEFUN CC-TI-SELECT-FIELD-POSSIBILITIES (SYL SYM)
1293    (COND ((ATOM SYM)
1294           (AND (CC-TI-MATCH SYL SYM)
1295                (LIST SYM)))
1296          (T
1297           (DO ((SYM SYM (CDR SYM)) (RESULT))
1298               ((NULL SYM) RESULT)
1299              (SETQ RESULT (NCONC (CC-TI-SELECT-FIELD-POSSIBILITIES SYL (CAR SYM)) RESULT))))))
1300
1301;Match the list of characters SYL against the head of the symbol SYM.
1302(DEFUN CC-TI-MATCH (SYL SYM)
1303 (COND ((EQ SYM T) NIL)         ;T ISN'T REALLY A SYMBOL!
1304       ((DO ((SYL SYL (CDR SYL))
1305             (N 1 (1+ N)))
1306            ((NULL SYL) T)
1307         (OR (= (CAR SYL) (GETCHARN SYM N))
1308             (RETURN NIL))))))
1309
1310(DEFUN ELIMINATE-DUPLICATES (L)
1311  (COND ((NULL L) NIL)
1312        ((MEMQ (CAR L) (CDR L))
1313         (ELIMINATE-DUPLICATES (CDR L)))
1314        ((CONS (CAR L) (ELIMINATE-DUPLICATES (CDR L))))))
1315
1316(DEFUN CC-ADR-CLOSE-ENOUGH (TARGET POSSIBILITY)
1317  (OR (EQ TARGET POSSIBILITY)
1318      (AND (EQ TARGET 'RAMMO) (EQ POSSIBILITY 'RAFSO)) ;FUNC SRCS ARE OK AS M MEMORY
1319    ))
1320
1321;;;MICRO-LOADER
1322
1323(DEFVAR CC-FILE-SYMBOLS-LOADED-FROM NIL)
1324
1325(IF-FOR-MACLISP
1326(DEFUN CC-LOAD-UCODE FEXPR (L)
1327  (CC-UCODE-LOADER NIL L NIL))
1328
1329(DEFUN CC-LOAD-BOOTSTRAP FEXPR (L)              ;LOAD WITHOUT SYMBOLS AND DONT AFFECT
1330  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS L NIL)); CURRENT SYMTAB
1331
1332(DEFUN CC-LOAD-UCODE-SYMBOLS FEXPR (L)
1333  (CC-UCODE-LOADER 'LOAD-SYMBOLS L NIL))
1334
1335(DEFUN CC-COMPARE-UCODE FEXPR (L)
1336  (CC-UCODE-LOADER 'COMPARE L NIL))
1337)
1338
1339(IF-FOR-LISPM
1340(DEFUN CC-LOAD-UCODE (FILE &OPTIONAL MERGEP)
1341  (CC-UCODE-LOADER NIL FILE MERGEP)
1342  (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE))
1343
1344(DEFUN CC-LOAD-BOOTSTRAP (FILE)
1345  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL))
1346
1347(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP)
1348  (COND ((EQUAL FILE CC-FILE-SYMBOLS-LOADED-FROM))
1349        ((AND (NULL MERGEP)
1350              (CC-SELECT-SYMBOL-TABLE FILE)))
1351        (T
1352         (CC-UCODE-LOADER 'LOAD-SYMBOLS FILE MERGEP)
1353         (CC-RECORD-SYMBOL-TABLE (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE)))))
1354
1355(DEFUN CC-COMPARE-UCODE (FILE)
1356  (CC-UCODE-LOADER 'COMPARE FILE NIL))
1357)  ;end if for LISPM
1358
1359(DEFUN WORDEX MACRO (X)
1360  (SUBST (+ 16. (* -16. (CADR X))) 'BAR
1361    (SUBST (CADDR X) 'FOO
1362        '(BOOLE 1 177777 (LSH FOO BAR)) )))
1363
1364;(DEFUN CC-MAIN-MEMORY-BLOCK-WRITE (ADR DATA)
1365;       (CNSWDB RACMWD (WORDEX 3 DATA) (WORDEX 2 DATA) (WORDEX 1 DATA))
1366;       (CNSWDB RACPMW (WORDEX 3 ADR) (WORDEX 2 ADR) (WORDEX 1 ADR)))
1367
1368(DEFUN READ-FIXNUM (FILE)               ;HOPEFULLY FAST FIXNUM-ONLY READER, NCALL'ABLE
1369  (PROG (CH NUM SGN)
1370        (DECLARE (FIXNUM CH NUM SGN))
1371        (SETQ NUM 0 SGN 1)
1372  A     (AND (< (SETQ CH (TYI FILE)) 41)  ;IGNORE LEADING GARBAGE
1373             (GO A))
1374        (AND (> CH 177) (GO A))
1375        (COND ((= CH 55)
1376               (SETQ SGN -1))
1377              ((GO C)))
1378  B     (SETQ CH (TYI FILE))
1379  C     (COND ((= CH 137)
1380               (RETURN (* SGN (LSH NUM (READ-FIXNUM FILE)))))
1381              ((AND (> CH 57) (< CH 70))
1382               (SETQ NUM (+ (LSH NUM 3) CH -60))
1383               (GO B))
1384              ((> CH 40)
1385               (ERROR CH 'RANDOM-CHAR-IN-READ-FIXNUM 'FAIL-ACT)))
1386        (RETURN (* SGN NUM))))
1387
1388
1389(DEFUN CC NIL                   ;MAIN LOOP OF CONS CONSOLE PROGRAM
1390  (PROG (CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER
1391          CC-LAST-OPEN-REGISTER CC-LAST-VALUE-TYPED COM-CH TEM)
1392        (SETQ QF-SWAP-IN-LOOP-CHECK NIL)
1393        #M (CNSPMI)  ;FLUSH LOOKBEHIND ON CC-UNIBUS-MAP
1394        (IF-FOR-MACLISP (CC-SET-TTY-STATUS))
1395        (CC-CONSOLE-INIT)
1396        #Q (AND (EQ DBG-ACCESS-PATH 'DL11)
1397                (USER:INIT-DL11-UNIBUS-CHANNEL))
1398        (LET #Q ((STANDARD-OUTPUT CC-OUTPUT-STREAM)) #M ()
1399          (PROG ()
1400             (TERPRI)
1401             (PRINC (COND (CC-FULL-SAVE-VALID
1402                           '|CC contains saved state, type control-S to flush it.|)
1403                          (T '|Getting fresh state from machine.|)))
1404             (TERPRI)
1405             (CC-CONSOLE-STATUS-DISPLAY T)    ;dont touch machine since saved state may
1406                                              ;not be valid
1407         L0  (SETQ CC-ARG NIL)
1408             (AND (SIGNP GE (- (CAR (CURSORPOS)) CC-FIRST-STATUS-LINE))
1409                  (PROGN (CURSORPOS 'Z) (TERPRI)))
1410         L   (SETQ CC-SYL (CC-GETSYL-READ-TOKEN))
1411             (COND ((NUMBERP CC-SYL)
1412                    (GO L1))
1413                   ((EQ CC-SYL '*RUB*) ;OVER RUB-OUT
1414                    (GO ERR1))
1415                   ((EQ CC-SYL '/@)     ;VARIOUS REG ADDR SPACES + MISC COMMANDS
1416                    (GO COM))
1417                   ((EQ CC-SYL '/)     ;EXIT TO LISP
1418                    (GO X))
1419                   ((EQ CC-SYL '/_)     ;VARIOUS TYPE-OUT MODES
1420                    (GO UND))
1421                   ((EQ CC-SYL '/`)     ;VARIOUS TYPE-IN MODES
1422                    (GO IND))
1423                   ((EQ CC-SYL '/')     ;TYPE-IN OVER EXISTING FIELDS
1424                    (GO INDOV))
1425                   ((EQ CC-SYL '/.)     ;"POINT"
1426                    (SETQ CC-SYL CC-LAST-OPEN-REGISTER)
1427                    (GO L1))
1428                   ((EQ CC-SYL '/:)     ;VARIOUS SYMBOLIC COMMANDS
1429                    (GO CLN))
1430                   ((SETQ TEM (CC-LOOKUP-NAME CC-SYL))
1431                    (SETQ CC-SYL TEM)
1432                    (GO L1)))
1433            L2     (COND ((SETQ TEM (GET CC-SYL 'CC-COMMAND))
1434                          (GO COM1)))
1435            ERR   (PRIN1 CC-SYL)
1436            ERR1  (PRINC '??/ / )
1437            (GO L0)
1438
1439  L1    (COND ((NUMBERP CC-ARG)
1440                (SETQ CC-ARG (PLUS CC-ARG CC-SYL)))
1441              (T (SETQ CC-ARG CC-SYL)))
1442        (GO L)
1443
1444  COM   (SETQ COM-CH (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))
1445        (COND ((SETQ TEM (GET COM-CH 'CC-LOWEST-ADR))
1446                (COND ((NULL CC-ARG) (SETQ CC-ARG 0)))
1447                (SETQ CC-ARG (+ CC-ARG (SYMEVAL TEM)))
1448                (GO L)))
1449        (SETQ CC-SYL COM-CH)
1450        (GO L2)
1451  COM1  (SETQ CC-VAL (FUNCALL TEM CC-ARG))
1452        (COND (CC-UPDATE-DISPLAY-FLAG
1453                (CC-CONSOLE-STATUS-DISPLAY NIL)
1454                (SETQ CC-UPDATE-DISPLAY-FLAG NIL)))
1455        (COND ((NUMBERP CC-VAL)
1456                (SETQ CC-ARG CC-VAL)
1457                (GO L))
1458              (T (GO L0)))
1459
1460  UND   (SETQ CC-SYL (CC-CHAR-UPCASE (CC-GETSYL-RCH)))  ;VARIOUS TYPEOUT COMMANDS
1461        (OR CC-ARG (SETQ CC-ARG CC-LAST-VALUE-TYPED))
1462        (COND ((OR (AND (> CC-SYL 57) (< CC-SYL 72))
1463                   (= CC-SYL 55))
1464                (SETQ CC-GETSYL-UNRCH CC-SYL            ;IF DIGIT OR MINUS,
1465                      CC-SYL (CC-GETSYL-READ-TOKEN))    ;READ WHOLE NUMBER
1466                (SETQ CC-SYL (LOGAND 37 CC-SYL))        ;AND LEFT-ROTATE BY THAT
1467                (SETQ CC-ARG
1468                      (LOGIOR (LOGLDB (+ CC-SYL (CC-SHIFT (- 40 CC-SYL) 6)) CC-ARG)
1469                              (CC-SHIFT (LOGLDB (- 40 CC-SYL) CC-ARG) CC-SYL)))
1470                (AND (EQ CC-GETSYL-UNRCH-TOKEN '/ )
1471                     (SETQ CC-GETSYL-UNRCH-TOKEN '=))
1472                (GO L)))        ;N_N<SPACE> TYPES OUT, OTHERWISE IS TYPE-IN!
1473        (PRINC '/ )
1474        (OR (SETQ COM-CH (ASSQ (SETQ CC-SYL (ASCII CC-SYL))
1475                               CC-MODE-DESC-TABLE))
1476            (GO ERR))
1477        (CC-TYPE-OUT CC-ARG (CDR COM-CH) T NIL)
1478        (SETQ CC-LAST-VALUE-TYPED CC-ARG)       
1479        (PRINC '/ / )
1480        (GO L0)
1481
1482  IND   (SETQ CC-SYL (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))  ;VARIOUS TYPEIN COMMANDS
1483        (PRINC '/ )
1484        (OR (SETQ COM-CH (ASSQ CC-SYL CC-MODE-DESC-TABLE))
1485            (GO ERR))
1486        (SETQ CC-SYL (CC-TYPE-IN (CDR COM-CH) 0 NIL))
1487        (GO L1)
1488
1489  INDOV (SETQ CC-SYL (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))
1490        (PRINC '|/
1491[EDIT] | )
1492        (OR (SETQ COM-CH (ASSQ CC-SYL CC-MODE-DESC-TABLE))
1493            (GO ERR))
1494        (SETQ CC-SYL (CC-TYPE-IN (CDR COM-CH) CC-LAST-VALUE-TYPED T))
1495        (GO L1)
1496
1497  X     (IF-FOR-MACLISP (CC-RESTORE-TTY-STATUS))
1498        (RETURN T)
1499
1500  CLN   (SETQ CC-SYL (CC-GETSYL-READ-TOKEN))  ;:FOOBAR ETC.
1501        (OR (SETQ TEM (GET CC-SYL 'CC-COLON-CMD))
1502            (GO ERR1))
1503        (GO COM1)
1504))))
1505
1506(DEFUN CC-CHAR-UPCASE (CHAR)
1507    (DECLARE (FIXNUM CHAR))
1508    (COND ((AND (> CHAR 140)
1509                (< CHAR 173))
1510           (LOGXOR 40 CHAR))
1511          (T CHAR)))
1512
1513(DEFUN CC-PRINT-REG-ADR-CONTENTS (ADR)
1514 (PROG (RANGE DATA PCPART)
1515        (SETQ RANGE (CC-FIND-REG-ADR-RANGE ADR))
1516        (SETQ DATA (COND ((EQ RANGE 'RAIDR)
1517                          (CC-RAID-REG (- ADR RARDRO))) ;RAIDR RANGE IS IN 10
1518                         ((CC-REGISTER-EXAMINE ADR))))
1519        (SETQ CC-LAST-VALUE-TYPED DATA)
1520        (COND ((OR (MEMQ RANGE '(C CIB)) (= ADR RAIR) (= ADR RASIR))
1521               (CC-TYPE-OUT DATA CC-UINST-DESC T NIL))
1522              ((MEMQ RANGE '(U OPC))
1523               (SETQ PCPART (\ DATA (- RACME RACMO)))
1524               (CC-PRINT-ADDRESS (+ PCPART RACMO))      ;PCP PART SYMBOLICALLY
1525               (COND ((NOT (= DATA PCPART))             ;RESIDUE, IF ANY, NUMERICALLY
1526                      (PRINC '| + |)
1527                      (PRIN1 (- DATA PCPART))))
1528               (PRINC '/ ))
1529              ((EQ RANGE 'RAIDR)
1530                (CC-PRINT-ADDRESS DATA) (PRINC '/ ))
1531              (T (PRIN1-THEN-SPACE DATA)))
1532        (PRINC '/ / )))
1533
1534;RETURNS:  NIL IF NONE FOUND CLOSER THAN 20 TO DESIRED REG ADR
1535;          SYMBOL  IF EXACT MATCH FOUND
1536;          (LIST SYMBOL DIFFERENCE)  IF ONE FOUND CLOSER THAN 20
1537
1538(DEFUN CC-FIND-REG-ADR-RANGE (REG-ADR)
1539        (COND ((< REG-ADR RACMO) 'TOO-LOW)
1540              ((< REG-ADR RACME) 'C)
1541              ((< REG-ADR RADME) 'D)
1542              ((< REG-ADR RAPBE) 'P)
1543              ((< REG-ADR RAM1E) '/1)
1544              ((< REG-ADR RAM2E) '/2)
1545              ((< REG-ADR RAAME) 'A)
1546              ((< REG-ADR RAUSE) 'U)
1547              ((< REG-ADR RAMME) 'M)
1548              ((< REG-ADR RAFSE) 'FS)
1549              ((< REG-ADR RAFDE) 'FD)
1550              ((< REG-ADR RARGE) 'CC)
1551              ((< REG-ADR RACSWE) 'CSW)
1552              ((< REG-ADR RARDRE) 'RAIDR)
1553              ((< REG-ADR RACIBE) 'CIB)
1554              ((< REG-ADR RAOPCE) 'OPC)
1555              ((< REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET) 'TOO-HIGH)
1556              ((< REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET) 'PHYSICAL)
1557              (T 'VIRTUAL)))
1558
1559(DEFPROP C RACMO CC-LOWEST-ADR)
1560(DEFPROP D RADMO CC-LOWEST-ADR)
1561(DEFPROP P RAPBO CC-LOWEST-ADR)
1562(DEFPROP /1 RAM1O CC-LOWEST-ADR)
1563(DEFPROP /2 RAM2O CC-LOWEST-ADR)
1564(DEFPROP A RAAMO CC-LOWEST-ADR)
1565(DEFPROP U RAUSO CC-LOWEST-ADR)
1566(DEFPROP M RAMMO CC-LOWEST-ADR)
1567(DEFPROP FS RAFSO CC-LOWEST-ADR)
1568(DEFPROP FD RAFDO CC-LOWEST-ADR)
1569(DEFPROP CC RARGO CC-LOWEST-ADR)
1570(DEFPROP CSW RACSWO CC-LOWEST-ADR)
1571(DEFPROP RAIDR RARDRO CC-LOWEST-ADR)
1572(DEFPROP CIB RACIBO CC-LOWEST-ADR)
1573(DEFPROP OPC RAOPCO CC-LOWEST-ADR)
1574
1575(DEFPROP C C CC-@-NAME)
1576(DEFPROP D D CC-@-NAME)
1577(DEFPROP P P CC-@-NAME)
1578(DEFPROP /1 1 CC-@-NAME)
1579(DEFPROP /2 2 CC-@-NAME)
1580(DEFPROP A A CC-@-NAME)
1581(DEFPROP U U CC-@-NAME)
1582(DEFPROP M M CC-@-NAME)
1583
1584(DEFUN CC-PRINT-ADDRESS-1 (REG-ADR WD ITEMREST)
1585    WD ITEMREST
1586    (CC-PRINT-ADDRESS REG-ADR))
1587
1588(DEFUN CC-PRINT-ADDRESS (REG-ADR)
1589  (PROG (RANGE-NAME RANGE-BASE @-NAME TEM)
1590        (SETQ RANGE-NAME (CC-FIND-REG-ADR-RANGE REG-ADR))
1591        (COND ((AND (SETQ TEM (CC-FIND-CLOSEST-SYM REG-ADR))
1592                    (OR (ATOM TEM)
1593                        (EQ RANGE-NAME 'C)
1594                        (EQ RANGE-NAME 'D)))
1595                (PRIN1 TEM))
1596              ((SETQ RANGE-BASE (GET RANGE-NAME 'CC-LOWEST-ADR))
1597                (COND ((SETQ @-NAME (GET RANGE-NAME 'CC-@-NAME))
1598                        (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE)))
1599                        (PRINC '@)
1600                        (PRIN1 @-NAME))
1601                      (T (PRIN1 RANGE-NAME)
1602                         (PRINC '/ )
1603                         (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE))))))
1604              (T (PRIN1 REG-ADR)))
1605     X  (RETURN T)
1606))
1607
1608(DEFUN CC-CONSOLE-STATUS-DISPLAY (DONT-TOUCH-MACHINE)
1609   (PROG (SAVE-CURSOR-POS PC IR)
1610        (SETQ SAVE-CURSOR-POS (CURSORPOS))
1611        (CURSORPOS CC-FIRST-STATUS-LINE 0)
1612        (CURSORPOS 'E)
1613        (PRINC '***********************************************)
1614        (TERPRI)
1615        (CC-ENTER)
1616        (PRINC 'PC=)
1617        (PRINC (SETQ PC (CC-REGISTER-EXAMINE RAPC)))
1618        (PRINC '/ / / )
1619        (SETQ IR (CC-REGISTER-EXAMINE RASIR))
1620        (PRINC 'OBUS=)
1621        (PRINC (CC-REGISTER-EXAMINE RAOBS))
1622        (PRINC '|   |)
1623        (PRIN1 (CC-FIND-CLOSEST-SYM (+ PC RACMO)))      ;PRINT SYMBOLIC PC
1624        (TERPRI)
1625        (PRINC 'IR=)
1626   ;if comming in at top level, dont print contents of M or A mem location that does
1627   ;not have symbolic name.  Problem is that examining does CC-NOOP-CLOCK which results
1628   ;in loss of state, increments PC, etc etc.
1629        (CC-TYPE-OUT IR CC-UINST-DESC T DONT-TOUCH-MACHINE)
1630        (TERPRI)
1631        (PRINC 'ERROR-STATUS)
1632        (PRINC '/ )
1633        (CC-PRINT-ERROR-STATUS  (CC-REGISTER-EXAMINE RASTS))
1634        (DBG-PRINT-STATUS)      ;PRINT UNIBUS, XBUS  PARERRS, NXM
1635        (TERPRI)
1636        (CC-RAID)
1637        (CURSORPOS (CAR SAVE-CURSOR-POS) (CDR SAVE-CURSOR-POS)) ;RESTORE CURSOR POS
1638))
1639
1640(DEFUN CC-PRINT-SET-BITS (NUM BIT-LIST)
1641  (PROG (BIT-NUM THIS-BIT-SET)
1642        (SETQ BIT-NUM 0)
1643   L    (COND ((OR (= 0 NUM)
1644                   (NULL BIT-LIST))
1645                (RETURN T)))
1646        (COND ((SETQ THIS-BIT-SET (NOT (= 0 (LOGLDB (+ (LSH BIT-NUM 6) 0001) NUM))))
1647               (SETQ NUM (LOGDPB 0 (+ (LSH BIT-NUM 6) 0001) NUM))))
1648        (COND ((NULL (CAR BIT-LIST)))
1649              ((NOT (ATOM (CAR BIT-LIST)))
1650                (COND ((FUNCALL (CAAR BIT-LIST) THIS-BIT-SET)
1651                        (PRIN1 (CADAR BIT-LIST))
1652                        (PRINC '/ ))))
1653              (THIS-BIT-SET (PRIN1 (CAR BIT-LIST))
1654                            (PRINC '/ )))
1655        (SETQ BIT-NUM (1+ BIT-NUM))
1656        (SETQ BIT-LIST (CDR BIT-LIST))
1657        (GO L)))
1658
1659
1660(DEFUN CC-STORE (REG-ADR QUAN)
1661   (COND ((EQ 'RAIDR (CC-FIND-REG-ADR-RANGE REG-ADR))
1662          (STORE (CC-RAID-REG (- REG-ADR RARDRO)) QUAN))
1663         (T (CC-REGISTER-DEPOSIT REG-ADR QUAN))))
1664
1665(DEFUN CC-RAID ()
1666  (DO ((I 0 (1+ I))
1667       (TEM)
1668       (CC-LAST-VALUE-TYPED))
1669      ((= I 8))
1670    (COND ((NOT (ZEROP (SETQ TEM (CC-RAID-REG I))))
1671           (CC-PRINT-ADDRESS TEM)
1672           (PRINC '|//   |)
1673           (CC-PRINT-REG-ADR-CONTENTS TEM)
1674           (SETQ TEM (CURSORPOS))
1675           (COND ((< (CDR TEM) 40.)
1676                  (CURSORPOS (CAR TEM) 40.))
1677                 ((TERPRI))) ))))
1678
1679(DEFPROP // CC-SLASH CC-COMMAND)
1680
1681(DEFUN CC-SLASH (ADR)
1682  (PROG NIL
1683        (COND ((NULL ADR) (RETURN NIL)))
1684        (SETQ CC-OPEN-REGISTER ADR)
1685        (SETQ CC-LAST-OPEN-REGISTER CC-OPEN-REGISTER)
1686        (PRINC '/ / / )
1687        (CC-PRINT-REG-ADR-CONTENTS ADR)
1688))
1689
1690(PUTPROP (ASCII 15) 'CC-CR 'CC-COMMAND)
1691
1692(DEFUN CC-CR (QUAN)
1693  (PROG NIL
1694        (COND ((AND QUAN CC-OPEN-REGISTER)
1695               (CC-STORE CC-OPEN-REGISTER QUAN)))
1696        (SETQ CC-OPEN-REGISTER NIL)
1697        (TERPRI)
1698))
1699
1700(PUTPROP (ASCII 12) 'CC-LF 'CC-COMMAND)
1701
1702(DEFUN CC-LF (QUAN)
1703  (PROG (TEM)
1704        (CC-CR QUAN)
1705        (CC-PRINT-ADDRESS (SETQ TEM (1+ CC-LAST-OPEN-REGISTER)))
1706        (PRINC '//)
1707        (CC-SLASH TEM) ))
1708
1709(DEFPROP ^ CC-UPAR CC-COMMAND)
1710
1711(DEFUN CC-UPAR (QUAN)
1712  (PROG (TEM)
1713        (CC-CR QUAN)
1714        (CC-PRINT-ADDRESS (SETQ TEM (1- CC-LAST-OPEN-REGISTER)))
1715        (PRINC '//)
1716        (CC-SLASH TEM) ))
1717
1718(PUTPROP (ASCII 40) 'CC-SPACE 'CC-COMMAND)
1719(PUTPROP '+ 'CC-SPACE 'CC-COMMAND)
1720
1721(DEFUN CC-SPACE (ARG)
1722   ARG)
1723
1724(PUTPROP (ASCII 14) 'CC-FORM 'CC-COMMAND)
1725
1726(DEFUN CC-FORM (QUAN)
1727        QUAN
1728        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1729        NIL)
1730
1731(DEFPROP = CC-EQUALS CC-COMMAND)
1732
1733(DEFUN CC-EQUALS (QUAN)
1734        (AND QUAN (SETQ CC-LAST-VALUE-TYPED QUAN))
1735        #M (SETQ QUAN (STATUS _))
1736        #M (SSTATUS _ NIL)
1737        (PRIN1 CC-LAST-VALUE-TYPED)
1738        #M (SSTATUS _ QUAN)
1739        (PRINC '/ / / )
1740        NIL)
1741
1742(DEFPROP G CC-GO CC-COMMAND)
1743
1744(DEFUN CC-GO (QUAN)
1745       (CC-REGISTER-DEPOSIT RASA QUAN)
1746       (SETQ CC-UPDATE-DISPLAY-FLAG T)
1747       (TERPRI)
1748        NIL)
1749
1750(DEFPROP / CC-STEP CC-COMMAND)
1751
1752(DEFUN CC-STEP (QUAN)
1753 (PROG (QN)
1754        (SETQ QN (OR QUAN 1))
1755        (CC-REGISTER-DEPOSIT RASTEP QN)
1756        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1757        (AND QUAN (TERPRI))
1758        (RETURN NIL)))
1759
1760(DEFPROP / CC-RESET CC-COMMAND)
1761
1762(DEFUN CC-RESET (QUAN)
1763        (CC-REGISTER-DEPOSIT RARS (OR QUAN 0))
1764        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1765        (TERPRI)
1766        NIL)
1767
1768(DEFPROP Q CC-Q CC-COMMAND)
1769
1770(DEFUN CC-Q (QUAN)
1771        (PLUS (OR QUAN 0) CC-LAST-VALUE-TYPED))
1772
1773(DEFPROP / CC-STOP CC-COMMAND)
1774
1775(DEFUN CC-STOP (QUAN)
1776  (SETQ CC-PASSIVE-SAVE-VALID NIL)
1777  (SETQ CC-FULL-SAVE-VALID NIL)         ;ASSURE READING FRESH STUFF FROM HARDWARE
1778  (CC-REGISTER-DEPOSIT RASTOP QUAN)
1779  (SETQ CC-UPDATE-DISPLAY-FLAG T)
1780  (TERPRI) )
1781
1782(DEFPROP / CC-PROCEED CC-COMMAND)
1783
1784(DEFUN CC-PROCEED (QUAN)
1785  (PROG (CHAR)
1786        (QF-CLEAR-CACHE NIL)    ;CLEAR PHT CACHE
1787        (CC-REGISTER-DEPOSIT RAGO (OR QUAN 0))
1788        (PRINC #Q "RUN"
1789               #M (COND ((MEMQ 'SAIL (STATUS FILEMODE TYO))
1790                         '|RUN|)
1791                        (T '--RUN--)))
1792   L    (COND (#Q (SETQ CHAR (KBD-TYI-NO-HANG)) #M (NOT (ZEROP (LISTEN))) (GO X1))
1793              ((ZEROP (CC-REGISTER-EXAMINE RAGO)) (GO X)))
1794     #Q (PROCESS-SLEEP 30.)         ;WHY WAIT AS LONG?
1795     #M (SLEEP 2)
1796        (GO L)     
1797   X1 #M(TYI)
1798        (COND ((= CHAR 203) (BREAK CC-MACHINE-RUNNING) (GO L)))
1799   X    (PRINC 'STOP)
1800        (CC-REGISTER-DEPOSIT RASTOP 0)
1801        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1802        (TERPRI) ))
1803
1804(PUTPROP (INTERN (ASCII 11)) 'CC-TAB 'CC-COMMAND)
1805
1806(DEFUN CC-TAB (QUAN)
1807  (PROG (TEM)
1808        (CC-CR NIL) ;DON'T CLOBBER OPEN REGISTER
1809        (SETQ TEM (OR QUAN CC-LAST-VALUE-TYPED))
1810        (SETQ TEM (PLUS CC-REG-ADR-VIRT-MEM-OFFSET (QF-POINTER TEM)))
1811        (CC-PRINT-ADDRESS TEM)
1812        (PRINC '//)
1813        (CC-SLASH TEM) ))
1814
1815(DEFPROP FOOBAR CC-FOO-BAR CC-COMMAND)
1816
1817(DEFUN CC-FOO-BAR (QUAN)
1818  (COND ((EQUAL QUAN 105)
1819         (CC-REGISTER-DEPOSIT RARS 0)
1820         (CC-GO 1)
1821         (CC-PROCEED NIL))
1822        (T (PRINC '|FOOBAR??  |) NIL)))
1823
1824(DEFPROP / CC-REMOTE-CONSOLE CC-COMMAND)
1825
1826;REMOTE CONSOLE MODE
1827(DEFUN CC-REMOTE-CONSOLE (N)
1828 (PROG ()
1829   (QF-CLEAR-CACHE NIL)         ;CLEAR PHT CACHE
1830   (CC-REGISTER-DEPOSIT RAGO 1)
1831   (SETQ CC-UPDATE-DISPLAY-FLAG T)
1832 A (AND #M (ZEROP (LISTEN)) #Q (NOT (KBD-TYI-NO-HANG)) (GO B))
1833   (SETQ N (TYI))
1834   (AND (= N 23) (GO Y))
1835   (AND (< N 40) (TYO N))
1836   (AND (= N 15) (TYO 12))   ;NEWIO IS FUCKED UP
1837   (CC-REGISTER-DEPOSIT RARCON N)
1838   (GO A)
1839
1840 B (SETQ N (CC-REGISTER-EXAMINE RARCON))
1841   (OR (ZEROP N) (GO D))
1842   (AND (ZEROP (CC-REGISTER-EXAMINE RAGO)) (GO X))
1843   (SLEEP 1)
1844   (GO A)
1845
1846 C (AND (ZEROP (SETQ N (CC-REGISTER-EXAMINE RARCON)))
1847        (GO A))
1848 D (TYO N)
1849   (AND (= N 15) (TYO 12))   ;NEWIO IS FUCKED UP
1850   (GO C)
1851 X (PRINC '|/
1852Machine Stopped/
1853|)
1854 Y (CC-REGISTER-DEPOSIT RASTOP 0)
1855   (SETQ CC-UPDATE-DISPLAY-FLAG T)
1856))
1857
1858;;;HIGHER LEVEL STUFF
1859
1860(DEFPROP AREAS CC-DESCRIBE-AREAS CC-COLON-CMD)
1861
1862(DEFUN CC-REGISTER-EXAMINE-FIXNUM (ADR)
1863  (LET ((CONTENTS (CC-REGISTER-EXAMINE ADR)))
1864    (OR (= (LOGLDB %%Q-DATA-TYPE CONTENTS) DTP-FIX)
1865        (ERROR (LIST ADR CONTENTS) 'SHOULD-BE-Q-FIXNUM 'FAIL-ACT))
1866    (LOGAND 77777777 CONTENTS) ))
1867
1868(DEFUN CC-REGISTER-EXAMINE-PTR (ADR)
1869  (LOGAND 77777777 (CC-REGISTER-EXAMINE ADR)))
1870
1871(DEFUN CC-SYMBOLIC-EXAMINE-REGISTER (REG)
1872  (LET ((ADR (CC-LOOKUP-NAME REG)))
1873    (COND ((NULL ADR)
1874           (PRINT REG) (PRINC '| is undefined.|) (TERPRI)
1875           0)
1876          (T (CC-REGISTER-EXAMINE ADR)))))
1877
1878(DEFUN CC-SYMBOLIC-DEPOSIT-REGISTER (REG VAL)
1879  (LET ((ADR (CC-LOOKUP-NAME REG)))
1880    (COND ((NULL ADR)
1881           (PRINT REG) (PRINC '| is undefined.|) (TERPRI))
1882          (T (CC-REGISTER-DEPOSIT ADR VAL)))))
1883
1884(DEFUN CC-DESCRIBE-AREAS (IGNORE)
1885  (TERPRI)
1886  (LET ((A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
1887        (A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
1888        (A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
1889        (A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))
1890
1891        (R-O (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
1892        (R-L (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH))
1893        (R-B (QF-INITIAL-AREA-ORIGIN 'REGION-BITS))
1894        (R-FP (QF-INITIAL-AREA-ORIGIN 'REGION-FREE-POINTER))
1895        (R-GCP (QF-INITIAL-AREA-ORIGIN 'REGION-GC-POINTER))
1896        (R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)))
1897   (DO ((AREA 0 (1+ AREA))
1898        (NAREAS 0) (BITS) (A-NAME))
1899       ((= AREA SIZE-OF-AREA-ARRAYS) (PRINC '|/
1900Number of active areas = |) (PRINC NAREAS) (TERPRI) )
1901       (SETQ A-NAME (QF-MEM-READ (+ A-N AREA)))
1902       (COND ((AND (= (LOGLDB %%Q-DATA-TYPE A-NAME) DTP-SYMBOL)
1903                   (NOT (ZEROP (LOGLDB %%Q-POINTER A-NAME))))
1904                (AND (SIGNP GE (- (CAR (CURSORPOS)) CC-FIRST-STATUS-LINE))
1905                     (PROGN (PRINC '**MORE**) (TYI)
1906                            (CURSORPOS 0 0) (CURSORPOS 'L)))
1907                (SETQ NAREAS (1+ NAREAS))
1908                (PRIN1 AREA)            ;AREA NUMBER
1909                (TYO #M 11 #Q 211)
1910                (CC-Q-PRINT-TOPLEV A-NAME)  ;AREA-NAME
1911                (TYO #M 11 #Q 211)
1912                (PRINC '|Region-size |)
1913                (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-RS AREA)))
1914                (PRINC '| Maximum-size |)
1915                (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-MS AREA)))
1916                (DO ((RN (LOGLDB %%Q-POINTER (QF-MEM-READ (+ A-RL AREA)))
1917                         (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-LT RN)))))
1918                     ((NOT (ZEROP (LOGAND 1_23. RN)))
1919                      (COND ((NOT (= AREA (LOGAND RN 777777)))
1920                             (PRINC '|Region thread not linked back to AREA!!|))))
1921                   (TERPRI)
1922                   (PRINC '|   R |)
1923                   (PRINC RN)
1924                   (PRINC '|: Origin |)
1925                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-O RN))))
1926                   (PRINC '| Length |)
1927                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-L RN))))
1928                   (PRINC '| Free-Ptr |)
1929                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-FP RN))))
1930                   (PRINC '| GC-Ptr |)
1931                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-GCP RN))))
1932                   (PRINC '| |)
1933                   (SETQ BITS (QF-MEM-READ (+ R-B RN)))
1934                   (PRINC (NTH (LOGLDB %%REGION-REPRESENTATION-TYPE BITS)
1935                               '(LIST STRUC 2 3)))
1936                   (PRINC '| |)
1937                   (PRINC (NTH (LOGLDB %%REGION-SPACE-TYPE BITS)
1938                               '(FREE OLD NEW STATIC FIXED EXITED EXIT EXTRA-PDL
1939                                 WIRED USER-PAGED COPY 13 14 15 16 17))))
1940                (TERPRI))))))
1941
1942
1943(DEFPROP ATOM CC-DESCRIBE-ATOM CC-COLON-CMD)
1944
1945(DEFUN CC-DESCRIBE-ATOM (TEM)
1946  (SETQ CC-GETSYL-UNRCH NIL CC-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
1947  (SETQ TEM (READ))     ;GET NAME OF ATOM USING LISP SYNTAX
1948  (TERPRI)
1949  (SETQ TEM (QF-SYMBOL TEM))
1950  (COND ((< TEM 0)
1951         (PRINC '|Not found.|)
1952         (TERPRI))
1953        (T (CC-DESCRIBE-THIS-ATOM TEM)))
1954  (TERPRI)
1955  NIL)
1956
1957(DEFUN CC-DESCRIBE-THIS-ATOM (ADR)
1958  (PRINT 'LOCATION)
1959  (PRIN1 (SETQ ADR (QF-POINTER ADR)))
1960  (PRINT 'VALUE)
1961  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (1+ ADR)))
1962  (PRINT 'FUNCTION)
1963  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 2)))
1964  (PRINT 'PLIST)
1965  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 3)))
1966  (PRINT 'PACKAGE)
1967  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 4)))
1968  (TERPRI))
1969
1970(DEFPROP AREA CC-WHICH-AREA CC-COLON-CMD)
1971(DEFUN CC-WHICH-AREA (ARG)
1972   (SETQ ARG (OR ARG CC-LAST-VALUE-TYPED))
1973   (LET ((AREA-NUM (QF-AREA-NUMBER-OF-POINTER ARG)))
1974      (PRINC '|Area # = |) (PRINC AREA-NUM) (PRINC '| |)
1975      (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-NAME)
1976                                         AREA-NUM)))
1977      (TERPRI)))
1978
1979(DEFPROP MAPS CC-MAPS CC-COLON-CMD)
1980(DEFUN CC-MAPS (ARG)
1981   (SETQ ARG (OR ARG CC-LAST-VALUE-TYPED))
1982   (PROG (L1MAPADR L1VAL L2MAPADR L2BITS L2VAL)
1983         (SETQ L1MAPADR (LOGLDB 1513 ARG))
1984         (SETQ L2BITS (LOGLDB 0805 ARG))
1985         (PRINC L1MAPADR) (PRINC '|@1// |)
1986          (PRIN1-THEN-SPACE (SETQ L1VAL (CC-REGISTER-EXAMINE (+ RAM1O L1MAPADR))))
1987         (PRINC (SETQ L2MAPADR (+ (CC-SHIFT L1VAL 5) L2BITS))) (PRINC '|@2// |)
1988          (PRIN1-THEN-SPACE (SETQ L2VAL (CC-REGISTER-EXAMINE (+ RAM2O L2MAPADR))))
1989         (TERPRI)))
1990
1991;;; STACK PRINTING STUFF
1992
1993(DECLARE (SPECIAL CC-STACK-VIRTUAL-ADDRESS-MODE CC-STACK-M-AP CC-STACK-PP
1994        CC-STACK-SPDL-FRAME-EXISTS 
1995        CC-STACK-A-QLBNDP CC-STACK-A-QLPDLO
1996        CC-STACK-A-QLBNDO CC-STACK-CURRENT-FRAME-TYPE
1997        CC-STACK-CURRENT-FRAME-CALL-STATE CC-STACK-CURRENT-FRAME-EXIT-STATE
1998        CC-STACK-CURRENT-FRAME-ENTRY-STATE CC-STACK-CURRENT-FRAME-FCTN
1999        CC-STACK-PREVIOUS-ACTIVE-FRAME
2000        CC-STACK-PREVIOUS-OPEN-FRAME CC-STACK-A-QCSTKG
2001        CC-STACK-MACRO-PC CC-STACK-USTACK-DATA))
2002
2003(DECLARE (SPECIAL %%LP-EXS-EXIT-PC
2004                %%LP-CLS-ADI-PRESENT
2005                %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2006                %%LP-CLS-DELTA-TO-OPEN-BLOCK
2007                %%LP-EXS-BINDING-BLOCK-PUSHED
2008                %%LP-EXS-MICRO-STACK-SAVED
2009                %%LP-ENS-NUM-ARGS-SUPPLIED))
2010
2011;MODE = NIL -> USE PDL BUFFER ADDRESSES AND ONLY PRINT WHATS IN P.B.
2012;     = T   -> USE VIRTUAL ADDRESSES  (NOT IMPLEMENTED NOW)
2013(DEFUN CC-STACK-SET-VARS-FROM-MACHINE (MODE)
2014  (PROG (PDL-BUFFER-HEAD PDL-BUFFER-VIRTUAL-ADDRESS) 
2015        (SETQ CC-STACK-VIRTUAL-ADDRESS-MODE MODE)
2016        (SETQ CC-STACK-USTACK-DATA (CC-GET-USTACK-DATA-LIST))
2017        (SETQ CC-STACK-M-AP (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2018              CC-STACK-PP (CC-SYMBOLIC-EXAMINE-REGISTER 'PP)
2019              CC-STACK-A-QLBNDP (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDP)
2020              CC-STACK-A-QLBNDO (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDO) )
2021        (COND ((NULL MODE)
2022                (SETQ CC-STACK-A-QLPDLO (CC-SYMBOLIC-EXAMINE-REGISTER
2023                                                'A-PDL-BUFFER-HEAD))
2024                (SETQ CC-STACK-M-AP (+ CC-STACK-M-AP RAPBO))
2025                (SETQ CC-STACK-PP (+ CC-STACK-PP RAPBO))
2026                (SETQ CC-STACK-A-QLPDLO (+ CC-STACK-A-QLPDLO RAPBO)))
2027              (T (SETQ CC-STACK-A-QLPDLO (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLPDLO))
2028                 (SETQ PDL-BUFFER-HEAD (LOGLDB %%Q-POINTER
2029                        (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-HEAD)))
2030                 (SETQ PDL-BUFFER-VIRTUAL-ADDRESS (LOGLDB %%Q-POINTER
2031                        (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS)))
2032                 (SETQ CC-STACK-M-AP (+ PDL-BUFFER-VIRTUAL-ADDRESS
2033                        (LOGAND 1777 (- CC-STACK-M-AP PDL-BUFFER-HEAD))))
2034                 (SETQ CC-STACK-PP (+ PDL-BUFFER-VIRTUAL-ADDRESS
2035                        (LOGAND 1777 (- CC-STACK-PP PDL-BUFFER-HEAD))))
2036                ))   ;RELOCATE AP, ETC TO VIRTUAL ADDRESSES
2037        (CC-STACK-CURRENT-FRAME-SETUP MODE)
2038        (SETQ CC-STACK-SPDL-FRAME-EXISTS NIL)
2039        (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2040                (SETQ CC-STACK-SPDL-FRAME-EXISTS
2041                         (NOT (ZEROP (LOGLDB %%M-FLAGS-QBBFL
2042                                             (CC-SYMBOLIC-EXAMINE-REGISTER
2043                                                        'M-FLAGS)))))))
2044        (SETQ CC-STACK-MACRO-PC
2045              (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
2046))
2047
2048;INDEX BACK TO PREVIOUS STACK FRAME
2049(DEFUN CC-STACK-NEXT-FRAME-SETUP (MODE)
2050  (PROG ()
2051        (COND ((NULL CC-STACK-PREVIOUS-ACTIVE-FRAME) (RETURN NIL)))
2052        (SETQ CC-STACK-M-AP CC-STACK-PREVIOUS-ACTIVE-FRAME)
2053        (CC-STACK-CURRENT-FRAME-SETUP MODE)
2054        (SETQ CC-STACK-USTACK-DATA NIL)
2055        (COND ((NOT (ZEROP (LOGLDB %%LP-EXS-MICRO-STACK-SAVED
2056                                   CC-STACK-CURRENT-FRAME-EXIT-STATE)))
2057               (SETQ CC-STACK-USTACK-DATA (CC-STACK-XFER-USTACK))))
2058        (SETQ CC-STACK-SPDL-FRAME-EXISTS
2059              (LOGLDB %%LP-EXS-BINDING-BLOCK-PUSHED CC-STACK-CURRENT-FRAME-EXIT-STATE))
2060        (RETURN T)
2061))
2062
2063
2064(DEFUN CC-STACK-XFER-USTACK ()
2065  (PROG (DATA LST)
2066        (SETQ CC-STACK-USTACK-DATA NIL)
2067   L    (COND ((NOT (> CC-STACK-A-QLBNDP CC-STACK-A-QLBNDO))
2068                (PRINT 'BIND-STACK-EXHAUSTED-DURING-USTACK-XFER)
2069                (RETURN NIL)))
2070        (SETQ LST (CONS (SETQ DATA (QF-MEM-READ CC-STACK-A-QLBNDP))
2071                        LST))
2072        (SETQ CC-STACK-A-QLBNDP (1- CC-STACK-A-QLBNDP))
2073        (COND ((= 0 (LOGLDB %%Q-FLAG-BIT DATA)) ;NFLAGB
2074               (GO L)))
2075        (RETURN LST)
2076))
2077
2078;SET UP VARS TO FRAME CC-STACK-M-AP POINTS
2079(DEFUN CC-STACK-CURRENT-FRAME-SETUP (MODE)
2080  (PROG (TEM)
2081    (COND ((NULL MODE)
2082        (SETQ CC-STACK-CURRENT-FRAME-CALL-STATE
2083                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 3)))
2084        (SETQ CC-STACK-CURRENT-FRAME-EXIT-STATE
2085                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 2)))
2086        (SETQ CC-STACK-CURRENT-FRAME-ENTRY-STATE
2087                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 1)))
2088        (SETQ CC-STACK-CURRENT-FRAME-FCTN (CC-REGISTER-EXAMINE CC-STACK-M-AP)) )
2089    (T  (SETQ CC-STACK-CURRENT-FRAME-CALL-STATE
2090                (CC-MEM-READ (- CC-STACK-M-AP 3)))
2091        (SETQ CC-STACK-CURRENT-FRAME-EXIT-STATE
2092                (CC-MEM-READ (- CC-STACK-M-AP 2)))
2093        (SETQ CC-STACK-CURRENT-FRAME-ENTRY-STATE
2094                (CC-MEM-READ (- CC-STACK-M-AP 1)))
2095        (SETQ CC-STACK-CURRENT-FRAME-FCTN (CC-MEM-READ CC-STACK-M-AP)) ))
2096
2097        (SETQ CC-STACK-CURRENT-FRAME-TYPE (NTH (LOGLDB %%Q-DATA-TYPE
2098                                                       CC-STACK-CURRENT-FRAME-FCTN)
2099                                                Q-DATA-TYPES))
2100        (SETQ TEM (LOGLDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2101                          CC-STACK-CURRENT-FRAME-CALL-STATE))
2102        (SETQ CC-STACK-PREVIOUS-ACTIVE-FRAME
2103                (COND ((= TEM 0) NIL)
2104                      (T (- CC-STACK-M-AP TEM)) ))
2105        (SETQ TEM (LOGLDB %%LP-CLS-DELTA-TO-OPEN-BLOCK
2106                          CC-STACK-CURRENT-FRAME-CALL-STATE))
2107        (SETQ CC-STACK-PREVIOUS-OPEN-FRAME
2108                (- CC-STACK-M-AP TEM))
2109        (SETQ CC-STACK-MACRO-PC (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2110                                       (LOGLDB %%LP-EXS-EXIT-PC
2111                                               CC-STACK-CURRENT-FRAME-EXIT-STATE))
2112                                      (T -1)))
2113))
2114
2115(DEFUN CC-STACK-SPACE-BIND-STACK NIL
2116 (PROG (TEM)
2117        (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2118                (COND (CC-STACK-SPDL-FRAME-EXISTS
2119                        (CC-STACK-SPACE-BINDING-BLOCK))))
2120              ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-U-ENTRY)
2121                (GO L1)))
2122   X    (RETURN T)
2123   L1   (SETQ TEM CC-STACK-USTACK-DATA)
2124   L2   (COND ((NULL TEM) (GO X))
2125              ((NOT (ZEROP (LOGAND (CAR CC-STACK-USTACK-DATA) 40000))) ;PPBSPC
2126                (CC-STACK-SPACE-BINDING-BLOCK)))
2127        (SETQ TEM (CDR TEM))
2128        (GO L2)))
2129
2130(DEFUN CC-STACK-SPACE-BINDING-BLOCK NIL
2131  (PROG (BOUND-LOC-POINTER PREV-CONTENTS)
2132   L    (COND ((NOT (> CC-STACK-A-QLBNDP CC-STACK-A-QLBNDO))
2133               (RETURN T)))
2134        (SETQ BOUND-LOC-POINTER (QF-MEM-READ CC-STACK-A-QLBNDP))
2135        (COND ((NOT (= DTP-LOCATIVE (LOGLDB %%Q-DATA-TYPE BOUND-LOC-POINTER)))
2136               (PRINT 'BOUND-LOC-POINTER-NOT-LOCATIVE)))
2137        (SETQ PREV-CONTENTS (QF-MEM-READ (1- CC-STACK-A-QLBNDP)))
2138        (SETQ CC-STACK-A-QLBNDP (- CC-STACK-A-QLBNDP 2))
2139        (COND ((NOT (= 0 (LOGLDB %%Q-FLAG-BIT PREV-CONTENTS)))  ;NFLAGB
2140               (GO L)))
2141        (RETURN T)
2142))
2143
2144(DEFPROP STKP CC-PRINT-PDL CC-COLON-CMD)
2145
2146(DEFUN CC-PRINT-PDL (CNT) (CC-PRINT-PDL-1 CNT T))
2147
2148(DEFPROP BAKTRACE CC-BAKTRACE CC-COLON-CMD)
2149(DEFPROP BACKTRACE CC-BAKTRACE CC-COLON-CMD)
2150
2151(DEFUN CC-BAKTRACE (CNT) (CC-PRINT-PDL-1 CNT NIL))
2152
2153(DEFUN CC-PRINT-PDL-1 (CNT PRINT-ARGS-FLAG)     ;ARG IS NUMBER OF BLOCKS TO PRINT
2154 (PROG (MODE)
2155        (SETQ MODE T)
2156        (TERPRI)
2157        (COND ((NULL CNT) (SETQ CNT 100005))
2158              ((< CNT 0) (SETQ CNT (- 0 CNT)) (SETQ MODE NIL))) ;NEG NUMBER OF BLOCKS DOESNT
2159                        ;GO THRU PAGING HAIR, ETC.
2160        (CC-STACK-SET-VARS-FROM-MACHINE MODE)
2161    L   (CC-STACK-PRINT-STACK-FRAME MODE PRINT-ARGS-FLAG)
2162        (COND ((< (SETQ CNT (1- CNT)) 0) (RETURN T))
2163              (#M (NOT (ZEROP (LISTEN)))
2164               #Q (KBD-TYI-NO-HANG)
2165               (RETURN 'LISTEN)))
2166        (CC-STACK-SPACE-BIND-STACK)
2167        (COND ((NULL (CC-STACK-NEXT-FRAME-SETUP MODE)) (RETURN T)))
2168        (GO L)
2169))
2170
2171(DEFUN CC-STACK-PRINT-STACK-FRAME (MODE PRINT-ARGS-FLAG)
2172  (PROG (ADR CNT) ;TEM ADL-POINTER ARG-DESC VAR-NAME SV-LIST-POINTER
2173        (DECLARE (FIXNUM ADR CNT)) ;TEM ADL-POINTER ARG-DESC SV-LIST-POINTER
2174        (PRIN1-THEN-SPACE CC-STACK-M-AP)
2175        (CC-Q-PRINT-TOPLEV CC-STACK-CURRENT-FRAME-FCTN)
2176        (PRINC '/[)
2177        (PRIN1 (LOGLDB %%LP-EXS-EXIT-PC CC-STACK-CURRENT-FRAME-EXIT-STATE))
2178        (PRINC '/])
2179        (COND ((NULL PRINT-ARGS-FLAG) (TERPRI) (RETURN T)))
2180        (SETQ ADR (1+ CC-STACK-M-AP))
2181        (SETQ CNT (LOGLDB %%LP-ENS-NUM-ARGS-SUPPLIED
2182                          CC-STACK-CURRENT-FRAME-ENTRY-STATE))
2183;       (COND ((AND (EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2184;                   (NOT (= 0 (LOGLDB-FROM-FIXNUM %%FEFH-SV-BIND
2185;                                    (QF-MEM-READ (LOGLDB-FROM-FIXNUM %%Q-POINTER
2186;                                                         CC-STACK-CURRENT-FRAME-FCTN))))))
2187;               (SETQ ADL-POINTER (LOGLDB-FROM-FIXNUM %%Q-POINTER
2188;                  (+ CC-STACK-CURRENT-FRAME-FCTN (LOGLDB-FROM-FIXNUM %%FEFHI-MS-ARG-DESC-ORG
2189;                     (QF-MEM-READ (LOGLDB-FROM-FIXNUM %%Q-POINTER
2190;                       (+ CC-STACK-CURRENT-FRAME-FCTN %FEFHI-MISC)))))))
2191;               (SETQ SV-LIST-POINTER (LOGLDB-FROM-FIXNUM %%Q-POINTER
2192;                  (+ CC-STACK-CURRENT-FRAME-FCTN %FEFHI-SPECIAL-VALUE-CELL-PNTRS)))))
2193    L   (COND ((= CNT 0) (TERPRI) (RETURN T)))
2194        (PRINC '/ )
2195;       (COND (ADL-POINTER
2196;               (SETQ ARG-DESC (QF-MEM-READ ADL-POINTER))
2197;               (SETQ VAR-NAME NIL)
2198;               (SETQ ADL-POINTER
2199;                 (+ ADL-POINTER
2200;                    1
2201;                    (COND ((= 0 (LOGLDB-FROM-FIXNUM %%FEF-NAME-PRESENT ARG-DESC)) 0)
2202;                           (T (SETQ VAR-NAME (QF-MEM-READ (+ ADL-POINTER 1))) 1))
2203;                    (COND ((OR (= (SETQ TEM (LOGLDB-FROM-FIXNUM %%FEF-INIT-OPTION ARG-DESC))
2204;                                  FEF-INI-PNTR)
2205;                               (= TEM FEF-INI-C-PNTR)
2206;                               (= TEM FEF-INI-OPT-SA)
2207;                               (= TEM FEF-INI-EFF-ADR))
2208;                             1)
2209;                           (T 0)))) ))
2210        (CC-Q-PRINT-TOPLEV (COND ((NULL MODE) (CC-REGISTER-EXAMINE ADR))
2211                                 (T (CC-MEM-READ ADR))))
2212        (SETQ CNT (1- CNT) ADR (1+ ADR))
2213        (GO L)
2214 ))
2215
2216(DEFUN CC-GET-USTACK-DATA-LIST NIL   ;RETURNS A LIST OF CONTENTS OF USTACK
2217   (PROG (USP DATA)                  ; CAR OF RESULT WOULD BE POPJ ED TO FIRST
2218        (SETQ USP (CC-SYMBOLIC-EXAMINE-REGISTER 'USP))
2219    L   (COND ((NOT (> USP 0)) (RETURN (NREVERSE DATA))))
2220        (SETQ DATA (CONS (CC-REGISTER-EXAMINE (+ USP RAUSO))
2221                         DATA))
2222        (SETQ USP (1- USP))
2223        (GO L)))
2224
2225
2226;;; BREAKPOINTS
2227
2228(DEFPROP HERE CC-HERE CC-COLON-CMD)
2229
2230(DEFUN CC-HERE (QUAN)
2231  (SETQ CC-REMOTE-CONSOLE-MODE T)
2232  QUAN)
2233
2234(DEFPROP THERE CC-THERE CC-COLON-CMD)
2235
2236(DEFUN CC-THERE (QUAN)
2237  (SETQ CC-REMOTE-CONSOLE-MODE NIL)
2238  QUAN)
2239
2240(DEFPROP LISTB CC-LIST-BREAKPOINTS CC-COLON-CMD)
2241
2242(DEFUN CC-LIST-BREAKPOINTS (QUAN)
2243  QUAN
2244  (AND CC-BREAKPOINT-LIST (PRINT 'PERMANENT-BREAKPOINTS))
2245  (DO X CC-BREAKPOINT-LIST (CDR X) (NULL X)
2246    (TERPRI) (CC-PRINT-ADDRESS (CAR X)))
2247  (AND CC-TEMPORARY-BREAKPOINT-LIST (PRINT 'TEMPORARY-BREAKPOINTS))
2248  (DO X CC-TEMPORARY-BREAKPOINT-LIST (CDR X) (NULL X)
2249    (TERPRI) (CC-PRINT-ADDRESS (CDR X)))
2250  (AND (NULL CC-BREAKPOINT-LIST) (NULL CC-TEMPORARY-BREAKPOINT-LIST)
2251       (PRINT 'NONE))
2252  (CC-CR NIL))
2253
2254(DEFPROP B CC-SET-PERM-BKPT CC-COLON-CMD)
2255
2256(DEFUN CC-SET-PERM-BKPT (QUAN)
2257  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) T)
2258  (CC-CR NIL))
2259
2260(DEFPROP TB CC-SET-TEMP-BKPT CC-COLON-CMD)
2261
2262(DEFUN CC-SET-TEMP-BKPT (QUAN)
2263  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) NIL)
2264  (CC-CR NIL))
2265
2266(DEFPROP TBP CC-SET-TEMP-BKPT-CONTIN CC-COLON-CMD)
2267
2268(DEFUN CC-SET-TEMP-BKPT-CONTIN (QUAN)
2269  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) NIL)
2270  (CC-CONTIN NIL))
2271
2272(DEFPROP G CC-LOAD-ADDR-CONTIN CC-COLON-CMD)
2273
2274(DEFUN CC-LOAD-ADDR-CONTIN (QUAN)
2275  (CC-GO 1)
2276  (CC-CONTIN QUAN))
2277
2278(DEFPROP P CC-CONTIN CC-COLON-CMD)
2279
2280(DEFUN CC-CONTIN (QUAN)
2281  QUAN
2282  (COND (CC-REMOTE-CONSOLE-MODE
2283         (CC-REMOTE-CONSOLE 0))
2284        (T (CC-PROCEED NIL)))
2285  (COND ((NOT (NULL CC-TEMPORARY-BREAKPOINT-LIST))
2286         (MAPC 'CC-UNSET-BREAKPOINT CC-TEMPORARY-BREAKPOINT-LIST)
2287         (PRINT '(TEMPORARY-BREAKPOINTS-REMOVED))))
2288  (CC-CR NIL))
2289
2290(DEFPROP UB CC-UNSET-BKPT CC-COLON-CMD)
2291
2292(DEFUN CC-UNSET-BKPT (LOC)
2293  (OR LOC (SETQ LOC CC-LAST-OPEN-REGISTER))
2294  (COND ((OR (MEMBER LOC CC-BREAKPOINT-LIST)
2295             (MEMBER LOC CC-TEMPORARY-BREAKPOINT-LIST))
2296           (CC-UNSET-BREAKPOINT (OR LOC CC-LAST-OPEN-REGISTER)))
2297        (T (PRINT 'NO-BREAKPOINT-AT)
2298           (CC-PRINT-ADDRESS LOC)))
2299  (CC-CR NIL))
2300
2301(DEFPROP UAB CC-UNSET-ALL-BKPTS CC-COLON-CMD)
2302 
2303(DEFUN CC-UNSET-ALL-BKPTS (QUAN)
2304  QUAN
2305  (MAPC 'CC-UNSET-BREAKPOINT CC-BREAKPOINT-LIST)
2306  (MAPC 'CC-UNSET-BREAKPOINT CC-TEMPORARY-BREAKPOINT-LIST)
2307  (CC-CR NIL))
2308
2309(DEFUN CC-SET-BREAKPOINT (LOC PERMANENT)
2310  (PROG (CONTENTS MF)
2311    (OR (EQ 'C (CC-FIND-REG-ADR-RANGE LOC))
2312        (RETURN (PRINT 'BKPT-NOT-IN-C-MEM)))
2313    (SETQ CONTENTS (CC-REGISTER-EXAMINE LOC))
2314    (SETQ MF (LOGLDB 1202 CONTENTS))
2315    (COND ((= MF 0))
2316          ((= MF 1) (PRINT '(WARNING/, BKPT ALREADY SET)))
2317          (T (RETURN (PRINT '(SORRY/, MF FIELD ALREADY IN USE THIS INSTRUCTION)))))
2318    (CC-REGISTER-DEPOSIT LOC (LOGDPB 1 1202 CONTENTS))
2319    (COND (PERMANENT
2320           (SETQ CC-BREAKPOINT-LIST (CONS LOC CC-BREAKPOINT-LIST)))
2321          ((SETQ CC-TEMPORARY-BREAKPOINT-LIST (CONS LOC CC-TEMPORARY-BREAKPOINT-LIST))))
2322   ))
2323
2324(DEFUN CC-UNSET-BREAKPOINT (LOC)
2325  (PROG (CONTENTS MF)
2326    (OR (EQ 'C (CC-FIND-REG-ADR-RANGE LOC))
2327        (RETURN (PRINT 'BKPT-NOT-IN-C-MEM)))
2328    (SETQ CONTENTS (CC-REGISTER-EXAMINE LOC))
2329    (SETQ MF (LOGLDB 1202 CONTENTS))
2330    (COND ((NOT (= MF 1))
2331           (PRINT 'BREAKPOINT-CLOBBERED)
2332           (CC-PRINT-ADDRESS LOC))
2333          (T (CC-REGISTER-DEPOSIT LOC (LOGDPB 0 1202 CONTENTS))))
2334    (SETQ CC-BREAKPOINT-LIST (DELETE LOC CC-BREAKPOINT-LIST))
2335    (SETQ CC-TEMPORARY-BREAKPOINT-LIST (DELETE LOC CC-TEMPORARY-BREAKPOINT-LIST))
2336   ))
2337
2338(DEFPROP CHECK-MAP CC-CHECK-MAP CC-COLON-CMD)
2339
2340(ARRAY CC-LEVEL-1-MAP-FREQUENCIES FIXNUM 32.)
2341(ARRAY CC-LEVEL-1-REVERSE-MAP FIXNUM 32.)
2342
2343(DEFUN CC-CHECK-MAP (TEM)
2344 (PROG (NUM-CHECKED-OK L1-MAP PRINT-MAP-FREQS)
2345  (SETQ NUM-CHECKED-OK 0)
2346  (DO I 0 (1+ I) (= I 32.)
2347      (STORE (CC-LEVEL-1-MAP-FREQUENCIES I) 0))
2348  (DO ((ADR RAM1O (1+ ADR)))
2349      ((= ADR RAM1E))
2350    (SETQ L1-MAP (CC-REGISTER-EXAMINE ADR))
2351    (COND ((OR (< L1-MAP 0) (> L1-MAP 31.))
2352           (PRINT (LIST 'BAD-LEVEL-1-MAP-VALUE ADR L1-MAP)))
2353          (T
2354            (STORE (CC-LEVEL-1-MAP-FREQUENCIES L1-MAP)
2355                   (SETQ TEM (1+ (CC-LEVEL-1-MAP-FREQUENCIES L1-MAP))))
2356            (COND ((AND (NOT (= L1-MAP 37))      ;NO LEVEL 1 MAP ENTRYS SHOULD BE DUPLICATED
2357                        (NOT (= TEM 1)))         ; EXCEPT 37
2358                   (FORMAT T "~%TRIGGERED ON L1-MAP ~O, FREQ ~O" L1-MAP TEM)
2359                   (SETQ PRINT-MAP-FREQS T)))
2360            (STORE (CC-LEVEL-1-REVERSE-MAP L1-MAP)
2361                   (- ADR RAM1O)))))
2362  (COND (PRINT-MAP-FREQS
2363          (DO ((I 0 (1+ I)))
2364              ((= I 32.))
2365            (PRINT (LIST 'LEVEL-1-MAP-VALUE I 'APPEARS (CC-LEVEL-1-MAP-FREQUENCIES I))))))
2366  (DO ((I 0 (1+ I))
2367       (NOT-37S 0))
2368      ((= I 31.)
2369       (PRINT (LIST 'NOT-37S NOT-37S)))
2370    (SETQ TEM (CC-LEVEL-1-MAP-FREQUENCIES I))
2371    (SETQ NOT-37S (+ NOT-37S TEM))
2372    (COND ((ZEROP TEM)
2373           (PRINT (LIST 'LEVEL-2-MAP-BLOCK I 'NOT-USED))
2374           (GO E))
2375          ((> TEM 1)
2376           (PRINT (LIST 'LEVEL-2-MAP-BLOCK I 'USED TEM 'TIMES))))
2377    (SETQ NUM-CHECKED-OK
2378          (+ (CC-CHECK-LEVEL-2-BLOCK (CC-SHIFT (CC-LEVEL-1-REVERSE-MAP I) 13.)
2379                                     I)
2380             NUM-CHECKED-OK))
2381    E)
2382  (PRINT (LIST NUM-CHECKED-OK 'MAP-ENTRIES-CHECKED-OK))
2383  (RETURN NIL)))
2384
2385(DECLARE (SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE))
2386
2387(DEFUN CC-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
2388 (PROG (L2M PHT-ADR PHT-VALUE VIR-ADR NUM-CHECKED-OK L2MAP-SA)
2389   (SETQ NUM-CHECKED-OK 0)
2390   (SETQ L2MAP-SA (+ RAM2O (LSH LEVEL-2-BLOCK-NUMBER 5)))
2391   (DO ADR-IN-BLOCK 0 (1+ ADR-IN-BLOCK) (= ADR-IN-BLOCK 32.)
2392       (SETQ L2M (CC-REGISTER-EXAMINE (+ ADR-IN-BLOCK L2MAP-SA)))
2393       (COND ((>= (LOGLDB %%PHT2-MAP-STATUS-CODE L2M)    ;IF LEVEL 2 MAP SET UP ...
2394                  %PHT-MAP-STATUS-READ-ONLY)
2395              (SETQ PHT-ADR (QF-PAGE-HASH-TABLE-LOOKUP
2396                             (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
2397              (COND ((< PHT-ADR 0)
2398                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-ADDRESS)
2399                            (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS
2400                                         VIR-ADR 'NOT-FOUND-IN-PHT))
2401                            (PRINT (LIST 'MAP-VALUE L2M
2402                                         'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
2403                                                                  5)
2404                                                             ADR-IN-BLOCK))))))
2405                    ((NOT (= (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER L2M)
2406                             (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER
2407                                     (SETQ PHT-VALUE (PHYS-MEM-READ (1+ PHT-ADR))))))
2408                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'DIFFERS-FROM-PHT))
2409                     (PRINT (LIST 'MAP-VALUE L2M
2410                                  'PHT-VALUE PHT-VALUE
2411                                  'PHT-ADR PHT-ADR
2412                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
2413                                                           5)
2414                                                      ADR-IN-BLOCK))))
2415                    (T (SETQ NUM-CHECKED-OK (1+ NUM-CHECKED-OK)))))))
2416   (RETURN NUM-CHECKED-OK)))
2417
2418(DEFPROP MEMSTAT CC-DESCRIBE-MEMORY CC-COLON-CMD)
2419
2420;:MEMSTAT TELL ALL ABOUT ALL PAGES THAT ARE SWAPPED IN
2421(DEFUN CC-DESCRIBE-MEMORY (TEM)
2422  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
2423  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
2424  ; META BITS, MAP STATUS, ACCESS CODE
2425  (DO L (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CC-DESCRIBE-MEMORY-COPY-OUT-PHT) NIL)
2426      (CDR L) (NULL L)                                  ;PROCESS EACH CONTIG AREA
2427    (DO LL (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (NREVERSE (CAR L)) NIL)
2428           (CDR LL) (NULL LL)
2429      (PRINT (CAAAR LL))                                ;FIRST VIRTUAL ADDRESS
2430      (TYO 11)
2431      (COND ((< (CADAAR LL) (LENGTH AREA-LIST))         ;PRINT AREA NAME, TRYING TO BE
2432             (PRIN1-THEN-SPACE (NTH (CADAAR LL) AREA-LIST)))    ;QUICK ABOUT IT
2433            (T (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ (CADAAR LL)
2434                                                  (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))))
2435               (TYO 40)))
2436      (PRIN1 (// (- (CAAAR LL)
2437                     (SETQ TEM (QF-POINTER              ;AREA NUMBER TO AREA ORIGIN
2438                                 (QF-MEM-READ (+ (CADAAR LL)
2439                                                 (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN))))))
2440                  PAGE-SIZE))                           ;FIRST RELATIVE PAGE NUM
2441      (COND ((> (LENGTH (CAR LL)) 1)                    ;IF MULTI PAGES CONTIG
2442             (PRINC '-)
2443             (PRIN1 (// (- (CAAR (LAST (CAR LL))) TEM) PAGE-SIZE))))
2444      (PRINC '|  -->  |)                                ;MAPS ONTO
2445      (CC-DESCRIBE-MEMORY-PRINT-ATTRIB (CAAR LL))))     ;SAY WHAT IT MAPS ONTO
2446  (TERPRI)
2447  NIL)
2448
2449(DEFUN CC-DESCRIBE-MEMORY-PRINT-ATTRIB (X)
2450  (PRIN1-THEN-SPACE (CADDDR X))                         ;PHYSICAL ADDRESS
2451  (AND (CADDR X) (PRIN1-THEN-SPACE (CADDR X)))          ;SWAP STATUS IF ABNORMAL
2452  (PRIN1-THEN-SPACE (CADR (CDDDDR X)))                  ;MAP STATUS
2453  (AND (CADDR (CDDDDR X))
2454       (PRIN1-THEN-SPACE (CADDR (CDDDDR X))))           ;ACCESS IF ANY
2455  (OR (= 0 (CAR (CDDDDR X)))
2456      (PRIN1 'META-BITS=)
2457      (PRIN1 (CAR (CDDDDR X)))))                        ;META BITS IF NON-ZERO
2458
2459  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
2460  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
2461  ; META BITS, MAP STATUS, ACCESS CODE
2462;CONVERT ONE LIST OF PAGES INTO N, FOR THE CONTIGUOUS SUBSETS
2463(DEFUN CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (LL PREV-CONTIG)
2464  (COND ((NULL PREV-CONTIG)
2465         (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL))))
2466        ((NULL LL)
2467         (LIST (NREVERSE PREV-CONTIG)))
2468        ((AND (= (- (CADDDR (CAR LL)) PAGE-SIZE)
2469                 (CADDDR (CAR PREV-CONTIG)))    ;PHYS ADDRS AGREE
2470              (EQ (CADDR (CAR LL)) (CADDR (CAR PREV-CONTIG)))   ;SWAP STATUS AGREE
2471              (EQUAL (CDDDDR (CAR LL)) (CDDDDR (CAR PREV-CONTIG)))) ;OTHER STUFF AGREES
2472         (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (CONS (CAR LL) PREV-CONTIG)))
2473        (T                                                      ;START NEW CONTIG FROB
2474         (CONS (NREVERSE PREV-CONTIG)
2475               (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL)))))))
2476
2477(DEFUN CC-DESCRIBE-MEMORY-COLLECT-CONTIG (SORTED-PHT-LIST PREVIOUS-CONTIG-LIST)
2478  (COND ((NULL SORTED-PHT-LIST)
2479         (AND PREVIOUS-CONTIG-LIST (LIST PREVIOUS-CONTIG-LIST)))
2480        ((NULL PREVIOUS-CONTIG-LIST)
2481         (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
2482                                            (LIST (CAR SORTED-PHT-LIST))))
2483        ((AND (= (CADAR SORTED-PHT-LIST) (CADAR PREVIOUS-CONTIG-LIST)) ;SAME AREA
2484              (= (CAAR SORTED-PHT-LIST)
2485                 (+ PAGE-SIZE (CAAR PREVIOUS-CONTIG-LIST)))) ;NEXT VIR ADR
2486         (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
2487                                            (CONS (CAR SORTED-PHT-LIST) PREVIOUS-CONTIG-LIST)))
2488        (T
2489         (CONS PREVIOUS-CONTIG-LIST
2490               (CC-DESCRIBE-MEMORY-COLLECT-CONTIG SORTED-PHT-LIST NIL)))))
2491
2492(DECLARE (SPECIAL %PHT-DUMMY-VIRTUAL-ADDRESS %%PHT1-VIRTUAL-PAGE-NUMBER))
2493
2494(DEFUN CC-DESCRIBE-MEMORY-COPY-OUT-PHT NIL
2495  (SORTCAR
2496    (DO ((PHTP (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-PNTR))) (+ PHTP 2))
2497         (COUNT (// (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) 2)
2498                (1- COUNT))
2499         (PHT1)
2500         (PHT2)
2501         (VIRAD)
2502         (LST NIL))
2503        ((= 0 COUNT) LST)
2504      (DECLARE (FIXNUM PHTP COUNT PHT1 PHT2 VIRAD))
2505      (COND ((AND (NOT (= 0 (LOGAND 100 (SETQ PHT1 (PHYS-MEM-READ PHTP)))))
2506                  (NOT (= %PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER PHT1))))
2507             (SETQ LST (CONS (LIST (SETQ VIRAD (* PAGE-SIZE             ;VIRTUAL ADDRESS
2508                                                  (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER PHT1)))
2509
2510                                   (QF-AREA-NUMBER-OF-POINTER VIRAD)    ;AREA NUMBER
2511                                   (NTH (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1)
2512                                        '(SWAP-STATUS-ZERO?
2513                                          NIL FLUSHABLE SWAP-STATUS-PDL-BUFFER
2514                                          AGE-TRAP WIRED SWAP-STATUS-6?
2515                                          SWAP-STATUS-7?))
2516                                   (* PAGE-SIZE         ;PHYSICAL ADDRESS
2517                                      (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER
2518                                              (SETQ PHT2 (PHYS-MEM-READ (1+ PHTP)))))
2519                                   (LOGLDB %%PHT2-META-BITS PHT2)
2520                                   (NTH (LOGLDB %%PHT2-MAP-STATUS-CODE PHT2)
2521                                        '(LEVEL-1-MAP-NOT-VALID?
2522                                          LEVEL-2-MAP-NOT-VALID?
2523                                          READ-ONLY READ-WRITE-FIRST READ-WRITE
2524                                          MAP-STATUS-PDL-BUFFER
2525                                          MAP-STATUS-6? MAP-STATUS-7?))
2526                                   (NTH (LOGLDB %%PHT2-MAP-ACCESS-CODE PHT2)
2527                                        '(NIL NIL R-ACCESS R-W-ACCESS)))
2528                             LST)))))
2529    (FUNCTION <)))
2530
2531(DEFPROP RELPC CC-RELPC CC-COLON-CMD)
2532
2533(DEFUN CC-RELPC (IGNORE)
2534  (PROG (M-AP LC)
2535        (SETQ M-AP (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2536                                           RAPBO)))
2537        (CC-Q-PRINT-TOPLEV M-AP)
2538        (COND ((= (LOGLDB %%Q-DATA-TYPE M-AP)
2539                  DTP-FEF-POINTER)
2540               (SETQ LC
2541                     (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
2542               (TYO 40)
2543               (PRIN1 (- (QF-POINTER LC)
2544                         (* 2 (QF-POINTER M-AP)))) ))))
2545
2546(DECLARE (SPECIAL %%LP-EXS-EXIT-PC %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2547                  %%LP-CLS-DELTA-TO-OPEN-BLOCK
2548                  %%LP-ENS-NUM-ARGS-SUPPLIED))
2549
2550(DEFUN (TRACE CC-COLON-CMD) (COUNT)
2551     (CC-TRACE-COMMAND COUNT T))
2552
2553(DEFUN (TRACEN CC-COLON-CMD) (COUNT)
2554     (CC-TRACE-COMMAND COUNT NIL))
2555
2556(DEFUN CC-TRACE-COMMAND (COUNT PRINT-ARGS-P)
2557    (TERPRI)
2558    (CC-TRACE-THE-STACK (COND ((NULL COUNT)
2559                               (SETQ COUNT 7777777)
2560                               (COND ((AND CC-LAST-VALUE-TYPED
2561                                           (= (QF-DATA-TYPE CC-LAST-VALUE-TYPED)
2562                                              DTP-STACK-GROUP))
2563                                      CC-LAST-VALUE-TYPED)
2564                                     (T T)))
2565                              ((MINUSP COUNT)
2566                               (SETQ COUNT (- COUNT))
2567                               NIL)
2568                              (T T))
2569                        PRINT-ARGS-P
2570                        COUNT))
2571
2572;; First argument, MODE, is NIL to use the current stack group from the pdl buffer,
2573;; T for the current stack group from memory, or a stack group to trace.
2574;; Second argument, PRINT-ARGS-P, is T if you want the arguments to be printed
2575;; for each frame.
2576(DEFUN CC-TRACE-THE-STACK (MODE PRINT-ARGS-P COUNT)
2577    (PROG (M-AP CALL-WORD EXIT-WORD ENTRY-WORD FUNCTION-WORD FRAME-TYPE TIMES)
2578          (SETQ TIMES 0)
2579          (SETQ M-AP
2580                (QF-POINTER
2581                 (COND ((NULL MODE)
2582                        (+ RAPBO (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)))
2583                       ((EQ MODE T)
2584                        (+ (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER
2585                                        'A-PDL-BUFFER-VIRTUAL-ADDRESS))
2586                           (LOGAND 1777 (- (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2587                                           (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER
2588                                                        'A-PDL-BUFFER-HEAD))))))
2589                       (T (SETQ MODE (QF-MAKE-Q MODE DTP-ARRAY-POINTER))
2590                          (LET ((RP (QF-ARRAY-LEADER MODE SG-REGULAR-PDL)))
2591                            (+ RP
2592                               (QF-ARRAY-LEADER MODE SG-AP)
2593                               1
2594                               (LOGLDB %%ARRAY-LONG-LENGTH-FLAG (CC-MEM-READ RP))))))))
2595        LOOP
2596          (OR #M (ZEROP (LISTEN)) #Q (NOT (KBD-TYI-NO-HANG)) (RETURN NIL))
2597          (COND ((NULL MODE)
2598                 (SETQ CALL-WORD (CC-REGISTER-EXAMINE (- M-AP 3)))
2599                 (SETQ EXIT-WORD (CC-REGISTER-EXAMINE (- M-AP 2)))
2600                 (SETQ ENTRY-WORD (CC-REGISTER-EXAMINE (- M-AP 1)))
2601                 (SETQ FUNCTION-WORD (CC-REGISTER-EXAMINE M-AP)))
2602                (T
2603                 (SETQ CALL-WORD (CC-MEM-READ (- M-AP 3)))
2604                 (SETQ EXIT-WORD (CC-MEM-READ (- M-AP 2)))
2605                 (SETQ ENTRY-WORD (CC-MEM-READ (- M-AP 1)))
2606                 (SETQ FUNCTION-WORD (CC-MEM-READ M-AP))))
2607          (SETQ FRAME-TYPE (NTH (LOGLDB %%Q-DATA-TYPE FUNCTION-WORD) Q-DATA-TYPES))
2608
2609          ;;; Print out info about this frame.
2610          (PRIN1-THEN-SPACE M-AP)
2611          (CC-Q-PRINT-TOPLEV FUNCTION-WORD)
2612          (COND ((AND (EQ FRAME-TYPE 'DTP-FEF-POINTER)
2613                      (NOT (AND (ZEROP TIMES)
2614                                (MEMQ MODE '(T NIL)))))
2615                 (PRINC '/[)
2616                 (PRIN1 (LOGLDB %%LP-EXS-EXIT-PC EXIT-WORD))
2617                 (PRINC '/])))
2618          (COND (PRINT-ARGS-P
2619                 (DO ((ADR (1+ M-AP) (1+ ADR))
2620                      (CC-SEXP-PRINLEVEL 2)
2621                      (CC-SEXP-PRINLENGTH 3)
2622                      (CNT (LOGLDB %%LP-ENS-NUM-ARGS-SUPPLIED ENTRY-WORD) (1- CNT)))
2623                     ((ZEROP CNT))
2624                   (DECLARE (FIXNUM ADR CNT))
2625                   (PRINC '| |)
2626                   (CC-Q-PRINT-TOPLEV (COND ((NULL MODE) (CC-REGISTER-EXAMINE ADR))
2627                                            (T (CC-MEM-READ ADR)))))))
2628          (TERPRI)
2629          (OR (< (SETQ TIMES (1+ TIMES)) COUNT)
2630              (RETURN NIL))
2631          (LET ((DELTA (LOGLDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK CALL-WORD)))
2632            (COND ((ZEROP DELTA) (RETURN NIL))
2633                  (T (SETQ M-AP (- M-AP DELTA))
2634                     (GO LOOP))))
2635          ))
2636
2637(DECLARE (SPECIAL %%FEFH-PC %FEFHI-IPC %FEFHI-STORAGE-LENGTH))
2638
2639(DECLARE (NOTYPE (CC-CODE-INSN FIXNUM FIXNUM FIXNUM)))
2640
2641(DEFUN (CODE CC-COLON-CMD) (ARG)
2642   (TERPRI)
2643   (LET ((PC (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
2644         (FEF (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2645                                      RAPBO))))
2646     (DECLARE (FIXNUM PC FEF))
2647     (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER))
2648            (PRINC '|The current function is not a FEF.|) (TERPRI))
2649           (T (SETQ FEF (QF-POINTER FEF))
2650              (PRINC '|Current FEF is |)
2651              (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ %FEFHI-FCTN-NAME FEF)))
2652              (TERPRI)
2653              (LET ((RELPC (- PC (* 2 FEF))))
2654                (DECLARE (FIXNUM RELPC))
2655                (COND ((OR (< RELPC 10) (> RELPC 10000))
2656                       (PRINC '|The PC does not seem to be pointer to the running FEF.|)
2657                       (TERPRI))
2658                      (T (CC-DISASSEMBLE-FEF FEF (COND ((EQ ARG 1) NIL)
2659                                                       (T RELPC))))))))))
2660
2661(DEFUN (DISASSEMBLE-FEF CC-COLON-CMD) (ARG)
2662  ARG
2663  (AND CC-LAST-VALUE-TYPED
2664       (= (QF-DATA-TYPE CC-LAST-VALUE-TYPED) DTP-FEF-POINTER)
2665       (PROGN (PRINC '|Type center PC or NIL|)
2666              (CC-DISASSEMBLE-FEF CC-LAST-VALUE-TYPED (READ)))))
2667
2668(DECLARE (NOTYPE (CC-DISASSEMBLE-FEF FIXNUM NOTYPE)))
2669
2670(DEFUN CC-DISASSEMBLE-FEF (FEF CENTER-PC)
2671  (LET ((FROM-RELPC 0) (TO-RELPC 0)
2672        (INIT-RELPC (LOGLDB %%FEFH-PC
2673                            (CC-MEM-READ (+ FEF %FEFHI-IPC))))
2674        (LIM-RELPC (* 2 (LOGLDB %%Q-POINTER
2675                                (CC-MEM-READ
2676                                  (+ FEF %FEFHI-STORAGE-LENGTH))))))
2677    (DECLARE (FIXNUM FROM-RELPC TO-RELPC INIT-RELPC LIM-RELPC))
2678    (SETQ FROM-RELPC
2679          (LOGAND -2 (COND ((NULL CENTER-PC) INIT-RELPC)
2680                           (T (MAX (- 10 CENTER-PC) INIT-RELPC)))))
2681    (SETQ TO-RELPC
2682          (COND ((NULL CENTER-PC) LIM-RELPC)
2683                (T (MIN (+ 3 CENTER-PC) LIM-RELPC))))
2684    (COND ((NULL CENTER-PC) (SETQ CENTER-PC -1)))
2685    (DO ((I FROM-RELPC (+ 2 I)))
2686        ((NOT (< I TO-RELPC)))
2687      (DECLARE (FIXNUM I))
2688      (LET ((WORD (QF-MEM-READ (+ (LSH I -1) FEF))))
2689        (DECLARE (FIXNUM WORD))
2690        (CC-CODE-INSN (LOGLDB 0020 WORD) I CENTER-PC)
2691        (CC-CODE-INSN (LOGLDB 2020 WORD) (1+ I) CENTER-PC)))))
2692
2693(DEFUN CC-CODE-INSN (INST ADDR CENTER-PC)
2694    (PRINC (COND ((= CENTER-PC ADDR) '|=> |)
2695                 (T '|   |)))
2696    (PRINC ADDR) (PRINC '| |)
2697    (CC-TYPE-OUT INST CC-INST-DESC T NIL)
2698    (TERPRI)
2699    NIL)
2700
2701(DEFUN (PF CC-COLON-CMD) (IGNORE)
2702  (COND ((NULL CC-OPEN-REGISTER)
2703         (PRINC '|NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)|))
2704        (T
2705    (LET ((CALL-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 3)))
2706          (EXIT-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 2)))
2707          (ENTRY-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 1)))
2708          (FUNCTION-WORD (CC-REGISTER-EXAMINE CC-OPEN-REGISTER)))
2709       (TERPRI) (CC-TYPE-OUT FUNCTION-WORD 'CC-SEXP-DESC T NIL)
2710       (TERPRI) (CC-TYPE-OUT CALL-WORD 'CALL-WORD-DESC 'ALL NIL)
2711       (TERPRI) (CC-TYPE-OUT EXIT-WORD 'EXIT-WORD-DESC 'ALL NIL)
2712       (TERPRI) (CC-TYPE-OUT ENTRY-WORD 'ENTRY-WORD-DESC 'ALL NIL)
2713     (COND ((NOT (ZEROP (LOGLDB %%LP-CLS-ADI-PRESENT CALL-WORD)))
2714            (DO ((ADR (- CC-OPEN-REGISTER 4) (- ADR 2))
2715                 (W1)(W2))
2716                (NIL)
2717              (DECLARE (FIXNUM ADR W1 W2))
2718              (SETQ W1 (CC-REGISTER-EXAMINE ADR)
2719                    W2 (CC-REGISTER-EXAMINE (- ADR 1)))
2720              (TERPRI)
2721              (CC-TYPE-OUT W1 'ADI-W1-DESC 'ALL NIL)
2722              (TERPRI)
2723              (CC-TYPE-OUT W2 'ADI-W2-DESC 'ALL NIL)
2724              (AND (ZEROP (LOGLDB %%Q-FLAG-BIT W2)) (RETURN NIL))))))))
2725  (TERPRI))
2726
2727(SETQ CALL-WORD-DESC '(
2728    (TYPE CALL-WORD)
2729    (SELECT-FIELD DOWNWARD-CLOSURE-PUSHED 2501 (NIL DOWNWARD-CLOSURE-PUSHED))
2730    (SELECT-FIELD ADI-PRESENT 2401 (NIL ADI-PRESENT))
2731    (SELECT-FIELD S-DEST 2004 (D-INDS D-PDL D-NEXT D-LAST D-RETURN T T D-NEXT-LIST D-MICRO))
2732    (TYPE-FIELD DELTA-TO-OPEN-BLOCK 1010 NIL)
2733    (TYPE-FIELD DELTA-TO-ACTIVE-BLOCK 0010 NIL)))
2734
2735(SETQ EXIT-WORD-DESC '(
2736    (TYPE EXIT-WORD)
2737    (SELECT-FIELD MICRO-STACK-SAVED 2101 (NIL MICRO-STACK-SAVED))
2738    (SELECT-FIELD BINDING-BLOCK-PUSHED 2001 (NIL BINDING-BLOCK-PUSHED))
2739    (TYPE-FIELD SAVED-PC 0017 NIL)))
2740
2741(SETQ ENTRY-WORD-DESC '(
2742    (TYPE ENTRY-WORD)
2743    (TYPE-FIELD NUM-ARGS 1006 NIL)
2744    (TYPE-FIELD LOC-BLOCK-ORIGIN 0010 NIL)))
2745
2746(SETQ ADI-W1-DESC '(
2747    (TYPE ADI-W1)
2748    (SELECT-FIELD FLAG-BIT 3501 (NO-FLAG-BIT-ERROR NIL))
2749    (SELECT-FIELD ADI-TYPE 2403 (ERR RETURN-INFO RESTART-PC FEXPR-CALL LEXPR-CALL
2750                                   BIND-STACK-LEVEL T USED-UP-RETURN-INFO))
2751    (SELECT-FIELD STORING-OPT 2103 (ERR BLOCK LIST MAKE-LIST INDIRECT T T T))
2752    (TYPE-FIELD NUM-VALS-EXPECTING 0006 NIL)))
2753
2754(SETQ ADI-W2-DESC '(
2755    (TYPE ADI-W2)
2756    (TYPE-FIELD FLAG-BIT 3501 NIL)
2757    (TYPE-FIELD W2 0030 NIL)))
2758
2759;Search physical memory (ie currently swapped in stuff) for arg.
2760(DEFUN (PHYS-MEM-WORD-SEARCH CC-COLON-CMD) (QUAN)
2761  (DECLARE (FIXNUM ADR TEM))
2762  (DO ((ADR 0 (1+ ADR))
2763       (TEM))
2764      ((OR (= ADR 400000) #Q (KBD-TYI-NO-HANG) #M NIL))   ;SEARCHES 128K  **CROCK**
2765      (COND ((= QUAN (SETQ TEM (PHYS-MEM-READ ADR)))
2766             (FORMAT T '|~%~S/  ~S  | ADR TEM)))))
2767
2768(DECLARE (SPECIAL CONS-FUNC-DEST-INT-CNTRL)) ;CADMAC does not get included in compilation
2769
2770;:INTOFF disables hardware interrupts and sequence breaks
2771(DEFUN (INTOFF CC-COLON-CMD) (IGNORE)
2772  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 0))
2773
2774(DEFUN (DESCRIBE CC-COLON-CMD) (IGNORE)
2775  (AND CC-LAST-VALUE-TYPED
2776       (LET ((DT (QF-DATA-TYPE CC-LAST-VALUE-TYPED)))
2777         (COND ((= DT DTP-STACK-GROUP)
2778                (CC-DESCRIBE-STACK-GROUP CC-LAST-VALUE-TYPED))
2779               ((OR (= DT DTP-CLOSURE)
2780                    (= DT DTP-ENTITY))
2781                (CC-DESCRIBE-CLOSURE CC-LAST-VALUE-TYPED))
2782               ((= DT DTP-FEF-POINTER)
2783                (CC-DESCRIBE-FEF CC-LAST-VALUE-TYPED))))))
2784
2785(IF-FOR-MACLISP
2786(DECLARE (SPECIAL SG-NAME SG-STATE %%SG-ST-IN-SWAPPED-STATE %%SG-ST-FOOTHOLD-EXECUTING
2787                  %%SG-ST-PROCESSING-ERROR %%SG-ST-CURRENT-STATE SG-STATES SG-SAVED-M-FLAGS
2788                  SG-REGULAR-PDL-POINTER SG-SPECIAL-PDL SG-SPECIAL-PDL-POINTER)))
2789
2790(DEFUN CC-DESCRIBE-STACK-GROUP (SG)
2791  (PROG (PNTR)
2792        (SETQ PNTR (QF-POINTER SG))
2793        (FORMAT T "~%Stack group: " )
2794        (CC-Q-PRINT-TOPLEV (CC-MEM-READ (- PNTR 2 SG-NAME)))
2795        (LET ((STATE (CC-MEM-READ (- PNTR 2 SG-STATE))))
2796           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-IN-SWAPPED-STATE STATE)))
2797                  (FORMAT T "~% Variables currently swapped out")))
2798           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-FOOTHOLD-EXECUTING STATE)))
2799                  (FORMAT T "~% Foothold currently executing")))
2800           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-PROCESSING-ERROR STATE)))
2801                  (FORMAT T "~% Currently processing an error")))
2802           (FORMAT T ", State ~S" (NTH (LOGLDB %%SG-ST-CURRENT-STATE STATE) SG-STATES)))
2803        (DO ((L STACK-GROUP-HEAD-LEADER-QS (CDR L))
2804             (A (- PNTR 2) (1- A))
2805             (WD))
2806            ((NULL L))
2807          (FORMAT T "~%~O~10T~A:~30T" A (CAR L))
2808          (SETQ WD (CC-MEM-READ A))
2809          (CC-TYPE-OUT WD CC-Q-DESC NIL NIL)
2810          (TYO #\TAB)
2811          (ERRSET (CC-Q-PRINT-TOPLEV WD)))
2812        (TERPRI)))
2813
2814(DEFUN CC-DESCRIBE-CLOSURE (CLOS)
2815    (FORMAT T "~%CLOSED-FUNCTION ")
2816    (CC-Q-PRINT-TOPLEV (QF-CAR CLOS))
2817    (DO ((L (QF-CDR CLOS) (QF-CDR (QF-CDR L))))
2818        ((CC-Q-NULL L))
2819      (FORMAT T "~%SYM: ")
2820      (CC-Q-PRINT-TOPLEV (1- (QF-SMASH-DATA-TYPE (QF-CAR L) DTP-SYMBOL)))
2821      (FORMAT T " VALUE:")
2822      (CC-Q-PRINT-TOPLEV (QF-CAR (QF-CAR (QF-CDR L))))))
2823
2824(DEFUN CC-P-LDB-OFFSET (PPSS PNTR OFF)
2825  (LOGLDB PPSS (CC-MEM-READ (+ PNTR OFF))))
2826
2827(DEFUN CC-P-CONTENTS-OFFSET (PNTR OFF)
2828       (LOGLDB %%Q-TYPED-POINTER (CC-MEM-READ (+ PNTR OFF))))
2829
2830(DEFUN CC-DESCRIBE-FEF (FEF &AUX HEADER NAME FAST-ARG SV MISC LENGTH DBI)
2831  (SETQ HEADER (CC-P-LDB-OFFSET %%HEADER-REST-FIELD FEF %FEFHI-IPC))
2832  (SETQ LENGTH (CC-P-CONTENTS-OFFSET FEF %FEFHI-STORAGE-LENGTH))
2833  (SETQ NAME (CC-P-CONTENTS-OFFSET FEF %FEFHI-FCTN-NAME))
2834  (SETQ FAST-ARG (CC-P-CONTENTS-OFFSET FEF %FEFHI-FAST-ARG-OPT))
2835  (SETQ SV (CC-P-CONTENTS-OFFSET FEF %FEFHI-SV-BITMAP))
2836  (SETQ MISC (CC-P-CONTENTS-OFFSET FEF %FEFHI-MISC))
2837  (FORMAT T "~%FEF for function ") (CC-Q-PRINT-TOPLEV NAME) (TERPRI)
2838  (FORMAT T "Initial relative PC: ~S halfwords.~%" (LOGLDB %%FEFH-PC HEADER))
2839; -- Print out the fast arg option
2840  (FORMAT T "The Fast Argument Option is ~A"
2841          (IF (ZEROP (LOGLDB %%FEFH-FAST-ARG HEADER))
2842              "not active, but here it is anyway:"
2843              "active:"))
2844  (SI:DESCRIBE-NUMERIC-DESCRIPTOR-WORD FAST-ARG)
2845; -- Randomness.
2846  (FORMAT T "~%The length of the local block is ~S~%"
2847          (LOGLDB %%FEFHI-MS-LOCAL-BLOCK-LENGTH MISC))
2848  (FORMAT T "The total storage length of the FEF is ~S~%"
2849          LENGTH)
2850; -- Special variables
2851  (COND ((ZEROP (LOGLDB %%FEFH-SV-BIND HEADER))
2852         (PRINC "There are no special variables present."))
2853        (T (PRINC "There are special variables, ")
2854           (TERPRI)
2855           (COND ((ZEROP (LOGLDB %%FEFHI-SVM-ACTIVE SV))
2856                  (PRINC "but the S-V bit map is not active. "))
2857                 (T (FORMAT T "and the S-V bit map is active and contains: ~O"
2858                            (LOGLDB %%FEFHI-SVM-BITS SV))))))
2859  (TERPRI)
2860; -- ADL.
2861  (COND ((ZEROP (LOGLDB %%FEFH-NO-ADL HEADER))
2862         (FORMAT T "There is an ADL:  It is ~S long, and starts at ~S"
2863                 (LOGLDB %%FEFHI-MS-BIND-DESC-LENGTH MISC)
2864                           (LDB %%FEFHI-MS-ARG-DESC-ORG MISC))
2865         (CC-DESCRIBE-ADL (CC-GET-MACRO-ARG-DESC-POINTER FEF))
2866         )
2867        (T (PRINC "There is no ADL.")))
2868  (TERPRI)
2869  DBI
2870; (COND ((SETQ DBI (FUNCTION-DEBUGGING-INFO FEF))
2871;        (FORMAT T "Debugging info:~%")
2872;        (DOLIST (ITEM DBI)
2873;                (FORMAT T "  ~S~%" ITEM))))
2874  )
2875   
2876(DEFUN CC-GET-MACRO-ARG-DESC-POINTER (FEF-POINTER &AUX ORIGIN)
2877   (COND ((= 0 (SETQ ORIGIN
2878                     (CC-P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG FEF-POINTER %FEFHI-MISC)))
2879          (CC-MAKE-POINTER DTP-SYMBOL 0))
2880         (T (CC-MAKE-POINTER-OFFSET DTP-LIST FEF-POINTER ORIGIN))))
2881
2882(DEFUN CC-MAKE-POINTER (DT PNTR)
2883       (LOGDPB DT %%Q-DATA-TYPE PNTR))
2884
2885(DEFUN CC-MAKE-POINTER-OFFSET (DT PNTR OFF)
2886       (LOGDPB DT %%Q-DATA-TYPE (+ PNTR OFF)))
2887
2888(DEFUN CC-DESCRIBE-ADL (ADL)
2889  (PROG (OPT-Q INIT-OPTION)
2890    L   (COND ((CC-Q-NULL ADL) (RETURN NIL)))
2891        (SETQ OPT-Q (QF-CAR ADL) ADL (QF-CDR ADL))
2892        (TERPRI)
2893        (COND ((NOT (ZEROP (LOGAND OPT-Q %FEF-NAME-PRESENT)))
2894               (PRINC "NAME ")
2895               (CC-Q-PRINT-TOPLEV (QF-CAR ADL))
2896               (SETQ ADL (QF-CDR ADL))))
2897        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-SPECIALNESS OPT-Q)
2898                               FEF-SPECIALNESS))
2899        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-DES-DT OPT-Q)
2900                               FEF-DES-DT))
2901        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-QUOTE-STATUS OPT-Q)
2902                               FEF-QUOTE-STATUS))
2903        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-ARG-SYNTAX OPT-Q)
2904                               FEF-ARG-SYNTAX))
2905        (PRIN1-THEN-SPACE (SETQ INIT-OPTION (NTH (LDB %%FEF-INIT-OPTION OPT-Q)
2906                                                 FEF-INIT-OPTION)))
2907        (COND ((MEMQ INIT-OPTION '(FEF-INI-PNTR FEF-INI-C-PNTR
2908                                   FEF-INI-OPT-SA FEF-INI-EFF-ADR))
2909               (PRINC "ARG ")
2910               (CC-Q-PRINT-TOPLEV (QF-CAR ADL))
2911               (SETQ ADL (QF-CDR ADL))))
2912        (GO L)
2913))
2914
2915
2916(DEFUN (FLAGS CC-COLON-CMD) (QUAN)
2917  (CC-TYPE-OUT (OR QUAN (CC-SYMBOLIC-EXAMINE-REGISTER 'M-FLAGS)) 'M-FLAGS-DESC 'ALL NIL))
2918
2919(SETQ M-FLAGS-DESC '(
2920    (TYPE M-FLAGS)
2921    (TYPE-FIELD M-QBFFL 0001 NIL)
2922    (SELECT-FIELD CAR-SYMBOL-MODE 0102 (ERROR NIL->NIL NIL ERROR))
2923    (SELECT-FIELD CAR-NUMBER-MODE 0302 (ERROR NIL ERROR ERROR))
2924    (SELECT-FIELD CDR-SYMBOL-MODE 0502 (ERROR NIL->NIL NIL PLIST))
2925    (SELECT-FIELD CDR-NUMBER-MODE 0702 (ERROR NIL ERROR ERROR))
2926    (SELECT-FIELD DONT-SWAP-IN 1101 (NIL DONT-SWAP-IN))
2927    (TYPE-FIELD TRAP-ENABLE 1201 NIL)
2928    (SELECT-FIELD MAR-MODE 1302 (NIL READ WRITE READ-AND-WRITE))
2929    (SELECT-FIELD PGF-WRITE 1501 (NIL PGF-WRITE))
2930    (SELECT-FIELD INTERRUPT 1601 (NIL INTERRUPT))
2931    (SELECT-FIELD SCAVENGE 1701 (NIL SCAVENGE))
2932    (SELECT-FIELD TRANSPORT 2001 (NIL TRANSPORT))
2933    (SELECT-FIELD STACK-GROUP-SWITCH 2101 (NIL STACK-GROUP-SWITCH))
2934    (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK)) ))
2935
Note: See TracBrowser for help on using the repository browser.