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

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

Update from System 78.

File size: 103.4 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 (ASSQ 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)  ;Don't do this, it just causes wastage later
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 100))
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 CC-ASCII-BYTE-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(DEFCONST CC-MODE-DESC-TABLE '((H . CC-HWD-DESC) (B . CC-BYTE-DESC)
478                               (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
479                               (I . CC-INST-DESC) (T . CC-ASCII-BYTE-DESC)
480                               (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
481                               (/# . CC-BITS-DESC)
482                               (N . CC-SIGNED-WORD-DESC)))
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; (SIGNED-NUM <FIELD-POSITION>) by special hack, it allows fields bigger than fixnum size.
507; (SUB-FIELD <DESCRIPTION-NAME>)
508;       call sub-description.
509; (COND <FIELD-NAME> <FIELD-POSITION> <LIST-OF-DESCRIPTIONS>)
510;       value of field selects element of list, do SUB-FIELD call to it.
511; (CONSTANT <FIELD-POSITION> <VALUE>)
512;       on type-in this constant is added in.
513; (CALL <FUNCTION> <FIELD-POSITION> . <ITEMREST>)
514;       for type-out, the function is called with 3 args.
515;       1st arg is field value.
516;       2nd arg is whole word
517;       3nd arg is <ITEMREST>.
518;       For input, <FUNCTION> should have an INPUT property which is the
519;       function to use for input.
520;       1st arg is the value accumulated so far.
521;       2nd arg is WD-BITS-SET, a mask with 1's in the bits whose values are known as yet.
522;       3rd arg is T if this is changing fields in the previous quantity.
523;       4th arg is the CDDR of the item, or (<FIELD-POSITION> . <ITEMREST>).
524; (IF-EQUAL <FIELD-NAME> <POSITION> <COMPARED-WITH> <DESC-IF-EQUAL> <DESC-IF-NOT>)
525;       This is like COND on typeout, except that it is a two way dispatch
526;       which compares a field's contents against a single distinguished value.
527;       The two DESC arguments should be desc lists or names of such.
528;       On input, if the field is already known, the appropriate branch is taken;
529;       otherwise, it is required that one of the branches be nil, and the
530;       other one is taken (always).
531; (INPUT . <DESCS>)
532;       the descriptors <DESCS> are processed only on input.
533; (OUTPUT . <DESCS>)
534;       the descriptors <DESCS> are processed only on output.
535; (BITS)  typeout only, type bit numbers of set bits.
536
537(DEFCONST CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
538
539(DEFCONST CC-BITS-DESC '( (BITS)))
540
541(DEFCONST CC-SIGNED-WORD-DESC '( (SIGNED-NUM 0040)))
542
543(DEFCONST CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)))
544
545(DEFCONST CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
546                         (NUM 2010) (CTYPE /,) (NUM 3010)))
547
548(DEFCONST CC-ASCII-BYTE-DESC '( (CHAR 0010) (CHAR 1010)
549                               (CHAR 2010) (CHAR 3010)))
550
551(DEFCONST CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
552
553
554(DEFCONST CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
555                      (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
556                      (SELECT-FIELD DATA-TYPE 3005
557                       (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
558                        GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
559                        HEADER-FORWARD BODY-FORWARD
560                           LOCATIVE LIST U-ENTRY FEF-POINTER
561                        ARRAY-POINTER ARRAY-HEADER STACK-GROUP CLOSURE SMALL-FLONUM
562                            SELECT-METHOD INSTANCE INSTANCE-HEADER
563                        ENTITY T T T T T T T))
564                      (NUM 0030)))
565
566(DEFCONST CC-A-DESC '( (CONSTANT 3005 2)        ;ARRAY-HEADER DATA-TYPE
567                      (SELECT-FIELD ARRAY-TYPE 2305
568                       (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q
569                        ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL
570                        ART-TVB ART-REG-PDL T T T T T T T T T T T T T T T T T T))
571                   (SELECT-FIELD HIGH-SPARE-BIT 2201 (NIL HIGH-SPARE-BIT))
572                   (SELECT-FIELD LEADER 2101 (NIL LEADER))
573                   (SELECT-FIELD DISPLACED 2001 (NIL DISPLACED))
574                   (SELECT-FIELD FLAG 1701 (NIL FLAG))
575                   (TYPE-FIELD /#DIMS 1403 NIL)
576                   (SELECT-FIELD LONG 1301 (NIL LONG))
577                   (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT))
578                   (TYPE-FIELD INDEX-LENGTH 0012 NIL)))
579
580(DEFCONST CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
581                       (CALL CALL0 MOVE CAR
582                        CDR CADR CDDR CDAR
583                        CAAR NIL NIL NIL
584                        NIL MISC T T))
585                      (COND OP-CODE 1104 (CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
586                        CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
587                        CC-I-DEST-DESC CC-I-DEST-DESC CC-I-DEST-DESC
588                        CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC
589                        CC-I-BR-DESC CC-I-DEST-DESC NIL NIL))
590                      (COND SUB-OP 1104 (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                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
593                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
594                        NIL CC-I-15-DESC NIL NIL))))
595
596(DEFCONST CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
597                          (IGNORE STACK NEXT LAST
598                           RETURN NEXTQ LASTQ NEXT-LIST))
599))
600
601(DEFCONST CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
602))
603
604(DEFCONST CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
605
606(DEFCONST CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
607                             (NUM 0006)))
608
609(DEFCONST 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(DEFCONST CC-I-11-DESC '( (SELECT-FIELD OP 1503
616                        (T + - * // LOGAND LOGXOR LOGIOR))
617))
618
619(DEFCONST CC-I-12-DESC '( (SELECT-FIELD OP 1503
620                        (= > < EQ SCDR SCDDR 1+ 1-))
621))
622
623(DEFCONST CC-I-13-DESC '( (SELECT-FIELD OP 1503
624                        (BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP))
625))
626
627(DEFCONST 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(DEFVAR CC-Q-PRINT-STRING-MAXL 200)
861
862(DEFUN CC-Q-PRINT-STRING (ADR)
863  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER))
864  (DO ((LEN (COND (QF-ARRAY-HAS-LEADER-P
865                   (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
866                  (T QF-ARRAY-LENGTH)))
867       (ADR QF-ARRAY-DATA-ORIGIN)
868       (I 0 (1+ I))
869       (CH)
870       (WD))
871      ((OR (>= I LEN) (= I CC-Q-PRINT-STRING-MAXL))
872       (AND (< I LEN) (PRINC '/././.) CC-OUTPUT-STREAM)
873       NIL)
874    (DECLARE (FIXNUM LEN ADR I WD))
875    (COND ((ZEROP (LOGAND 3 I)) ;Get next word
876           (SETQ WD (QF-MEM-READ ADR)
877                 ADR (1+ ADR))))
878    (SETQ CH (LOGAND 377 WD)
879          WD (CC-SHIFT WD -8))
880    (TYO CH CC-OUTPUT-STREAM))) ;On the pdp10, should check for format-effectors
881               
882(DEFUN CC-Q-PRINT-U-ENTRY (TYPED-POINTER I-PRINLEVEL)
883  (PROG (TEM)
884        (SETQ TEM (QF-INITIAL-AREA-ORIGIN 'MICRO-CODE-ENTRY-NAME-AREA))
885        (COND ((= TEM 0)
886                (RETURN (CC-Q-PRINT-BOMB TYPED-POINTER))))
887        (PRIN1-THEN-SPACE 'DTP-U-ENTRY)
888        (CC-Q-PRINT (QF-MEM-READ (+ TEM (LOGLDB %%Q-POINTER TYPED-POINTER))) I-PRINLEVEL)))
889
890(DEFUN CC-Q-PRINT-FRAME (TYPED-POINTER I-PRINLEVEL)
891  (PROG (TEM)
892        (SETQ TEM (CC-MEM-READ (+ %FEFHI-FCTN-NAME (LOGLDB %%Q-POINTER TYPED-POINTER))))
893        (PRINC '/#/<DTP-FEF-POINTER/ )
894        (CC-Q-PRINT TEM I-PRINLEVEL)
895        (PRINC '/ )
896        (PRIN1 (QF-POINTER TYPED-POINTER))
897        (PRINC '/>)))
898
899(DEFUN CC-Q-PRINT-BOMB (TYPED-POINTER)
900  (PROG (DATA-TYPE Q-POINTER)
901        (SETQ DATA-TYPE (LOGLDB %%Q-DATA-TYPE TYPED-POINTER))
902        (SETQ Q-POINTER (LOGLDB %%Q-POINTER TYPED-POINTER))
903        (PRINC '/#<)
904        (PRIN1 (NTH DATA-TYPE Q-DATA-TYPES))
905        (PRINC '/ )
906        (PRIN1 Q-POINTER)
907        (COND ((= DATA-TYPE DTP-NULL)
908               (TYO 40)
909               (CC-Q-PRINT-STRING (CC-MEM-READ TYPED-POINTER)))
910              ((= DATA-TYPE DTP-SYMBOL-HEADER)
911               (TYO 40)
912               (CC-Q-PRINT-STRING TYPED-POINTER))
913              ((= DATA-TYPE DTP-FEF-POINTER)
914               (TYO 40)
915               (CC-Q-PRINT-STRING (CC-MEM-READ (+ %FEFHI-FCTN-NAME TYPED-POINTER)))))
916        (PRIN1 '>)
917        (RETURN T)))
918
919(DEFUN CC-MEM-READ (ADDR)
920    (DO ((X (QF-MEM-READ ADDR) (QF-MEM-READ ADDR))
921         (DTP))
922        (NIL)
923      (SETQ DTP (QF-DATA-TYPE X))
924      (COND ((= DTP DTP-BODY-FORWARD)
925             (LET ((OFFSET (- (QF-POINTER ADDR) (QF-POINTER X))))
926               (SETQ X (+ (QF-MEM-READ X) OFFSET))))
927            ((OR (= DTP DTP-HEADER-FORWARD)
928                 (= DTP DTP-ONE-Q-FORWARD)
929                 (= DTP DTP-EXTERNAL-VALUE-CELL-POINTER))) ;loop
930            (T (RETURN X)))
931      (SETQ ADDR X)))
932
933(DEFUN CC-TYPE-OUT (WD DESC PROMPTP *DONT-TOUCH-MACHINE*)
934  (PROG (DC ITEM VAL TEM SYM-BASE)
935        (SETQ DC (COND ((ATOM DESC) (SYMEVAL DESC))
936                       (T DESC)))
937    L   (COND ((NULL DC) (RETURN T)))
938        (SETQ ITEM (CAR DC))
939        (COND ((EQ (CAR ITEM) 'TYPE-FIELD)
940                (GO T-F))
941              ((EQ (CAR ITEM) 'SELECT-FIELD)
942               (SETQ VAL (LOGLDB (CADDR ITEM) WD))
943               (SETQ TEM (NTH VAL (CADDDR ITEM)))
944               (OR (ATOM TEM)
945                   (SETQ TEM (COND (PROMPTP (AND (CADR TEM) (CAR TEM)))
946                                   (T (CAR TEM)))))
947               (COND ((NULL TEM))
948                     ((EQ TEM T)
949                       (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
950                       (PRIN1-THEN-SPACE (LOGLDB (CADDR ITEM) WD)))
951                     (T(AND (EQ PROMPTP 'ALL) (PRIN1-THEN-SPACE (CADR ITEM)))
952                       (PRIN1-THEN-SPACE TEM))))
953              ((EQ (CAR ITEM) 'SUB-FIELD)
954                (CC-TYPE-OUT WD (CADR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
955              ((EQ (CAR ITEM) 'COND)
956                (GO COND))
957              ((EQ (CAR ITEM) 'IF-EQUAL)
958               (SETQ TEM (CDDDDR ITEM))
959               (COND ((NOT (= (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM)))
960                      (SETQ TEM (CDR TEM))))
961               (AND (CAR TEM)
962                    (CC-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)))
963              ((EQ (CAR ITEM) 'CALL)
964                (FUNCALL (CADR ITEM) (LOGLDB (CADDR ITEM) WD) WD (CDDDR ITEM)))
965              ((EQ (CAR ITEM) 'TYPE)
966                (PRIN1-THEN-SPACE (CADR ITEM)))
967              ((EQ (CAR ITEM) 'CTYPE)
968                (TYO 10)
969                (PRINC (CADR ITEM)))
970              ((EQ (CAR ITEM) 'NUM)
971                (PRIN1-THEN-SPACE (LOGLDB (CADR ITEM) WD)))
972              ((EQ (CAR ITEM) 'SIGNED-NUM)
973               (PRIN1-THEN-SPACE (CC-UNSIGNED-TO-SIGNED (CADR ITEM)
974                                                        (LOGLDB-BIG (CADR ITEM) WD))))
975              ((EQ (CAR ITEM) 'CHAR)
976                (TYO (LOGLDB (CADR ITEM) WD)))
977              ((EQ (CAR ITEM) 'CONSTANT))
978              ((EQ (CAR ITEM) 'INPUT))
979              ((EQ (CAR ITEM) 'OUTPUT)
980               (CC-TYPE-OUT WD (CDR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
981              ((EQ (CAR ITEM) 'BITS)
982               (CC-PRINT-BITS WD))
983              (T (PRINT (LIST (CAR ITEM) 'IN ITEM  'UNKNOWN-DESCRIPTOR))))
984    L1  (SETQ DC (CDR DC))
985        (GO L)
986
987  T-F   (SETQ VAL (LOGLDB (CADDR ITEM) WD))
988        (COND ((NULL (CADDDR ITEM))                     ;3RD ARG IS NIL - PRINT NUMBER.
989               (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
990               (PRIN1-THEN-SPACE VAL)
991               (GO L1)))
992        (SETQ SYM-BASE (SYMEVAL (CADDDR ITEM)))
993        (COND ((MEMQ (CADDDR ITEM) '(RACMO RADMO))
994               (CC-C-OR-D-ADR-OUT (CADR ITEM) VAL SYM-BASE))
995              (T (CC-A-OR-M-ADR-OUT (CADR ITEM) VAL SYM-BASE)))
996        (GO L1)
997
998  COND  (SETQ VAL (LOGLDB (CADDR ITEM) WD))
999        (SETQ TEM (CADDDR ITEM))
1000  C-1   (COND ((NULL TEM) (GO L1))
1001              ((= VAL 0) (GO C-2)))
1002        (SETQ TEM (CDR TEM))
1003        (SETQ VAL (1- VAL))
1004        (GO C-1)
1005  C-2   (CC-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)
1006        (GO L1)
1007))
1008
1009;like LDB, but can load fields bigger than fixnum size.
1010(DEFUN LOGLDB-BIG (FLD WD)
1011  (PROG (ANS BITS BITS-OVER SHIFT)
1012        (SETQ SHIFT 0 ANS 0 BITS (LOGLDB 0006 FLD) BITS-OVER (LOGLDB 0620 FLD))
1013    L   (SETQ ANS (LOGIOR ANS (ASH (LOGLDB (LOGDPB BITS-OVER 0620 (MIN BITS 23.)) WD) SHIFT)))
1014        (IF ( (SETQ BITS (- BITS 23.)) 0) (RETURN ANS))
1015        (SETQ SHIFT (+ SHIFT 23.)
1016              BITS-OVER (+ BITS-OVER 23.))
1017        (GO L)))
1018
1019(DEFUN CC-UNSIGNED-TO-SIGNED (FLD WD)
1020  (LET ((SIGN-BIT (ASH 1 (1- (LDB 0006 FLD)))))
1021    (IF (NOT (ZEROP (LOGAND SIGN-BIT WD)))
1022        (MINUS (1+ (LOGXOR WD (1- (ASH SIGN-BIT 1)))))
1023        WD)))
1024
1025(DEFUN CC-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE)
1026    TYPE
1027    (PRIN1-THEN-SPACE (OR (CC-FIND-CLOSEST-SYM (+ SYM-BASE VAL)) VAL)))
1028
1029(DEFUN CC-A-OR-M-ADR-OUT (TYPE VAL SYM-BASE)
1030    (PROG (TEM)
1031        (COND ((ZEROP VAL) (RETURN NIL))
1032              ((OR (AND (SETQ TEM (CC-FIND-CLOSEST-SYM (+ SYM-BASE VAL)))
1033                        (ATOM TEM))
1034                   *DONT-TOUCH-MACHINE*)
1035               (COND ((NULL TEM)
1036                      (FORMAT T "~S@A" VAL))
1037                     (T
1038                      (PRIN1 TEM))))
1039              (T
1040               (PRIN1 VAL)
1041               (PRINC '/@)
1042               (PRINC TYPE)
1043               (PRINC '/[)
1044               (PRIN1 (CC-REGISTER-EXAMINE (+ VAL SYM-BASE)))
1045               (PRINC '/])))
1046        (PRINC '/ )))
1047
1048(IF-FOR-MACLISP
1049(DEFUN PRIN1-THEN-SPACE (X)
1050      (PRIN1 X)
1051      (PRINC '/ )))
1052
1053(DEFUN TYI-UPPERCASIFY NIL
1054  (PROG (CH)
1055        (SETQ CH (TYI CC-INPUT-STREAM))
1056        (COND ((AND (NOT (< CH 141))
1057                    (NOT (> CH 172)))
1058               (SETQ CH (- CH 40))))
1059        (RETURN CH)))
1060
1061(DEFUN CC-TYPE-IN (DESC WD TYPE-OVER)
1062 (PROG (DESC-STACK SYL N TEM CH ITEM WD-BITS-SET)
1063  (PRINC '/ )
1064  (SETQ WD-BITS-SET 0)          ;MASK FOR BITS SET THIS TIME AROUND
1065A (AND (ATOM DESC) (SETQ DESC (SYMEVAL DESC)))
1066B (SETQ ITEM '(OUTPUT))
1067  (CC-TI-CONTROL-SEQUENCE)
1068AA
1069  (COND ((NULL ITEM)
1070         (PRINC '|   |)
1071         (RETURN WD)))
1072  ;;DEAL WITH STANDARD CONTROL-SEQUENCE DESCRIPTORS IN STANDARD WAY.
1073  (AND (CC-TI-CONTROL-SEQUENCE) (GO AA))
1074  ;MAYBE THIS DESCRIPTION ITEM DOESN'T CALL FOR TYPE-IN?  OR NEEDS PROMPT
1075  (COND ((EQ (CAR ITEM) 'CONSTANT)
1076         (SETQ WD (PLUS WD (LOGDPB (CADDR ITEM) (CADR ITEM) 0)))
1077         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET))
1078         (GO B))
1079        ((EQ (CAR ITEM) 'CALL)
1080         (COND ((SETQ CH (GET (CADR ITEM) 'INPUT))
1081                (SETQ CH (FUNCALL CH WD WD-BITS-SET TYPE-OVER (CDDR ITEM)))
1082                (SETQ WD (CAR CH) WD-BITS-SET (CADR CH))
1083                (GO B))
1084               (T (PRINC '|I can't hack this |)
1085                  (RETURN NIL))))
1086        ;; We require that an IF-EQUAL either be determined from bits already set
1087        ;; or have only one non-empty alternative (which we always take).
1088        ((EQ (CAR ITEM) 'IF-EQUAL)
1089          (PUSH DESC DESC-STACK)
1090          (COND ((NOT (ZEROP (LOGLDB (CADDR ITEM) WD-BITS-SET)))
1091                 (SETQ DESC (COND ((= (CADDDR ITEM) (LOGLDB (CADDR ITEM) WD))
1092                                   (CAR (CDDDDR ITEM)))
1093                                  (T (CADR (CDDDDR ITEM))))))
1094                ((NULL (CAR (CDDDDR ITEM)))
1095                 (SETQ DESC (CADR (CDDDDR ITEM))))
1096                ((NULL (CADR (CDDDDR ITEM)))
1097                 (SETQ DESC (CAR (CDDDDR ITEM))))
1098                (T (BREAK 'BAD-IF-EQUAL-DESC-FOR-INPUT)))
1099          (GO B))
1100        ((AND (EQ (CAR ITEM) 'COND)     ;COND THAT DEPENDS ON PREVIOUS TYPE-IN
1101              (NOT (ZEROP (LOGLDB (CADDR ITEM) WD-BITS-SET))))
1102         (SETQ ITEM `(SUB-FIELD ,(NTH (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM))))
1103         (CC-TI-CONTROL-SEQUENCE)
1104         (GO AA))
1105        ((MEMQ (CAR ITEM) '(SELECT-FIELD TYPE-FIELD COND))
1106         (PRIN1-THEN-SPACE (CADR ITEM)))
1107        ((EQ (CAR ITEM) 'NUM)
1108         (PRINC '|#: |)))
1109  (SETQ SYL NIL)
1110
1111  ;ITEM IS A DESCRIPTOR, SYL HAS TYPE-IN SO FAR.
1112  ;HERE TO READ MORE.
1113C (COND (CC-LOW-LEVEL-FLAG (CC-REPLACE-STATE)))
1114  (SETQ CH (TYI-UPPERCASIFY))
1115  (COND ((OR (= CH 77) (= CH 40) (= CH 33)) (GO D))
1116        ((< CH 40)
1117         (TERPRI)
1118         (MAPC 'TYO SYL))
1119        ((= CH 177)
1120         (OR SYL (RETURN (PROGN (PRINC '|??  |) NIL)))
1121         (SETQ SYL (NREVERSE (CDR (NREVERSE SYL))))
1122         (CURSORPOS 'X))
1123        ((NULL SYL) (SETQ SYL (LIST CH)))
1124        ((RPLACD (LAST SYL) (LIST CH))))
1125  (GO C)
1126
1127  ;HAVE SOME TYPE-IN, CH HAS DELIMITER.
1128  D
1129  (COND ((AND TYPE-OVER (= CH 40) (NULL SYL))
1130         (GO K)))
1131 
1132  ;FIRST SET TEM TO LIST OF POSSIBLE COMPLETIONS
1133  (SETQ TEM (ELIMINATE-DUPLICATES (CC-TI-POSSIBILITIES SYL ITEM)))
1134  (COND ((NULL TEM)
1135         (PRINC '-IMPOSS-))
1136        ((= CH 77)
1137         (MAPC 'PRIN1-THEN-SPACE TEM))
1138        ((= CH 33)
1139         (GO F))
1140        ((COND ((NULL SYL)              ;CHECK FOR AMBIGUITY,
1141                (NOT (MEMQ NIL TEM)))   ;HACKING DEFAULT AND EXACT-MATCH
1142               ((AND (> (LENGTH TEM) 1)
1143                     (NOT (AND (MEMQ (SETQ CH (READLIST SYL)) TEM)
1144                               (SETQ TEM (CONS CH TEM)))) )))
1145         (PRINC '-AMBIG-))
1146        ((GO H)))
1147  ;RETYPE THE SYLLABLE AND READ MORE.
1148  (MAPC 'TYO SYL)
1149  (GO C)
1150
1151  ;HERE TO DO COMPLETION, SYL HAS LIST OF CHARS TYPED SO FAR,
1152  ;TEM HAS LIST OF POSSIBILITIES, TYPE OUT ALL CHARS THAT ARE FORCED.
1153F (CURSORPOS 'X)        ;UNECHO THE ALTMODE
1154  (AND (NUMBERP (CAR TEM))
1155       (GO C))          ;CAN'T COMPLETE PURE-NUMERIC TYPEIN
1156G (SETQ N (1+ (LENGTH SYL))) ;INDEX OF CHAR TO LOOK AT
1157  (SETQ CH (GETCHARN (CAR TEM) N))
1158  (AND (= CH 0) (GO C))
1159  ;CH HAS PROPOSED CHARACTER, SEE IF ALL POSSIBILITIES AGREE
1160  (AND (DO TEM (CDR TEM) (CDR TEM) (NULL TEM)
1161        (OR (= CH (GETCHARN (CAR TEM) N))
1162            (RETURN T)))
1163       (GO C))          ;DISAGREEMENT, STOP HERE
1164  (TYO CH)
1165  (COND ((NULL SYL) (SETQ SYL (LIST CH)))
1166        ((RPLACD (LAST SYL) (LIST CH))))
1167  (GO G)
1168
1169  ;TYPEIN HAS BEEN COMPLETED AND ACCEPTED, DIGEST IT.
1170H (SETQ TEM (AND SYL (CAR TEM)))
1171  (CURSORPOS 'B)        ;UNSPACE
1172  (OR (NUMBERP TEM)
1173      (NULL SYL)
1174      (DO ((CH)         ;DO FINAL STAGE OF COMPLETION
1175           (N (1+ (LENGTH SYL)) (1+ N)))
1176          (NIL)
1177        (AND (= 0 (SETQ CH (GETCHARN TEM N)))
1178             (RETURN NIL))
1179        (TYO CH)))
1180  (PRINC '/ )           ;SPACE AFTER FIELD
1181I (COND ((EQ (CAR ITEM) 'TYPE))
1182        ((EQ (CAR ITEM) 'SELECT-FIELD)
1183         (SETQ TEM (COND ((NUMBERP TEM) TEM)
1184                         ((AND (NULL SYL)
1185                               (MEMQ NIL (CDR (MEMQ NIL (CADDDR ITEM)))))
1186                          (GO B))               ;MULTIPLE NILS, DEFER DECISION
1187                         ((DO ((L (CADDDR ITEM) (CDR L)) (I 0 (1+ I))) ((NULL L) NIL)
1188                             (AND (OR (EQ (CAR L) TEM)
1189                                      (AND (NOT (ATOM (CAR L))) (MEMQ TEM (CAR L))))
1190                                  (RETURN I))))))
1191         (SETQ WD (LOGDPB TEM (CADDR ITEM) WD))
1192         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1193        ((EQ (CAR ITEM) 'TYPE-FIELD)
1194         (SETQ TEM (COND ((NUMBERP TEM) TEM)
1195                         ((NULL TEM) 0)
1196                         ((DIFFERENCE (CC-LOOKUP-NAME TEM)
1197                                      (SYMEVAL (CADDDR ITEM))))))
1198         (SETQ WD (LOGDPB TEM (CADDR ITEM) WD))
1199         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1200        ((EQ (CAR ITEM) 'NUM)
1201         (SETQ WD (LOGDPB TEM (CADR ITEM) WD))
1202         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET)))
1203        ((EQ (CAR ITEM) 'COND)
1204         (DO ((DL (CADDDR ITEM) (CDR DL))
1205              (N 0 (1+ N)))
1206             ((NULL DL) (BREAK COND-BARF T))
1207            (SETQ CH `(SUB-FIELD ,(CAR DL)))
1208            (COND ((MEMQ TEM (CC-TI-POSSIBILITIES SYL CH))
1209                   (SETQ WD (LOGDPB N (CADDR ITEM) WD))
1210                   (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET))
1211                   (RETURN NIL))))
1212         (SETQ ITEM CH)
1213         (CC-TI-CONTROL-SEQUENCE)
1214         (GO I))
1215        ((CC-TI-CONTROL-SEQUENCE) (GO I))
1216        (T (BREAK INPUT-LOSSAGE-GOBBLING)))
1217  (PRINC '/ )
1218  (GO B)
1219
1220  ;LEAVE THIS FIELD WITH SAME VALUE AS BEFORE
1221K (TYO 10)     ;Don't leave two spaces on the screen.
1222KK
1223  (COND ((EQ (CAR ITEM) 'TYPE))
1224        ((MEMQ (CAR ITEM) '(SELECT-FIELD TYPE-FIELD))
1225         (SETQ WD-BITS-SET (LOGDPB -1 (CADDR ITEM) WD-BITS-SET)))
1226        ((EQ (CAR ITEM) 'NUM)
1227         (SETQ WD-BITS-SET (LOGDPB -1 (CADR ITEM) WD-BITS-SET)))
1228        ((EQ (CAR ITEM) 'COND)
1229         (SETQ ITEM `(SUB-FIELD ,(NTH (LOGLDB (CADDR ITEM) WD) (CADDDR ITEM))))
1230         (CC-TI-CONTROL-SEQUENCE)
1231         (GO KK))
1232        ((CC-TI-CONTROL-SEQUENCE)
1233         (GO KK))
1234        (T (BREAK INPUT-LOSSAGE-SPACE)))
1235  (CC-TYPE-OUT WD (LIST ITEM) NIL NIL) ;RE-TYPE THE THING
1236  (PRINC '/ )
1237  (GO B)
1238))
1239
1240(DEFUN CC-TI-CONTROL-SEQUENCE ()
1241  (PROG ()
1242    (SELECTQ (CAR ITEM)
1243        ((SUB-FIELD INPUT)
1244          (PUSH DESC DESC-STACK)
1245          (SETQ DESC (COND ((EQ (CAR ITEM) 'INPUT) (CDR ITEM)) (T (CADR ITEM)))))
1246        (OUTPUT)
1247        (CTYPE
1248          (TYO 10)
1249          (PRINC (CADR ITEM)))
1250        (OTHERWISE (RETURN NIL)))
1251    LOOP
1252    (COND ((AND DESC (ATOM DESC))
1253           (SETQ DESC (SYMEVAL DESC))
1254           (GO LOOP))
1255          (DESC)
1256          (DESC-STACK (SETQ DESC (POP DESC-STACK))
1257                      (GO LOOP)))
1258    (SETQ ITEM (POP DESC))
1259    (RETURN T)))
1260
1261;Given a desc item ITEM, and given DESC and DESC-STACK as they are,
1262;compute the matches of the list of characters SYL against ITEM or the
1263;items that follow it/are called by it.
1264(DEFUN CC-TI-POSSIBILITIES (SYL ITEM)
1265  (LET ((DESC DESC) (DESC-STACK DESC-STACK))
1266     (PROG ()
1267         LOOP
1268         (RETURN (COND
1269               ((CC-TI-CONTROL-SEQUENCE) (GO LOOP))
1270               ((AND SYL (EVERY SYL '(LAMBDA (CH) (AND (> CH 57) (< CH 72)))))
1271                (LIST (READLIST SYL)))  ;IT IS, ONLY POSSIBILITY IS THAT NUMBER
1272               ((EQ (CAR ITEM) 'TYPE)
1273                (AND (CC-TI-MATCH SYL (CADR ITEM)) (CDR ITEM)))
1274               ((EQ (CAR ITEM) 'SELECT-FIELD)
1275                (CC-TI-SELECT-FIELD-POSSIBILITIES SYL (CADDDR ITEM)))
1276               ((EQ (CAR ITEM) 'NUM)
1277                NIL)    ;ONLY NUMBERS ALLOWED?
1278               ((EQ (CAR ITEM) 'TYPE-FIELD)
1279                (COND ((NULL (CADDDR ITEM)) NIL) ;ONLY NUMBERS ALLOWED?
1280                      ((NULL SYL)
1281                       (LIST NIL (IMPLODE (APPEND (EXPLODE (CADR ITEM)) '(- M E M - A D R)))))
1282                      (T        ;HACK COMPLETIONS OF REGISTER ADDRESSES
1283                       (LET ((FROM-I 0) (TO-I 0))
1284                            (COND ((NULL SYL)
1285                                   (SETQ FROM-I 0 TO-I CC-SYMBOLS-SIZE))
1286                                  (T (LET ((SYL+1 (APPEND SYL NIL)))
1287                                          (LET ((L (LAST SYL+1)))
1288                                               (RPLACA L (1+ (CAR L))))
1289                                          (SETQ FROM-I (CC-FIND-NAME (IMPLODE SYL))
1290                                                TO-I (CC-FIND-NAME (IMPLODE SYL+1))))))
1291                            (DO ((I FROM-I (1+ I))
1292                                 (ANS NIL))
1293                                ((NOT (< I TO-I)) (NREVERSE ANS))
1294                                (LET ((E (ARRAYCALL T CC-SYMBOLS-NAME I)))
1295                                     (AND (CC-ADR-CLOSE-ENOUGH
1296                                           (CADDDR ITEM)
1297                                           (GET (CC-FIND-REG-ADR-RANGE (CDR E))
1298                                                'CC-LOWEST-ADR))
1299                                          (SETQ ANS (CONS (CAR E) ANS))))))
1300                       )))
1301               ((EQ (CAR ITEM) 'COND)   ;HAIR....
1302                (PUSH DESC DESC-STACK)
1303                (MAPCAN (FUNCTION (LAMBDA (DESC)
1304                            (AND (ATOM DESC) (SETQ DESC (SYMEVAL DESC)))
1305                            (COND ((NULL DESC) NIL)
1306                                  ((APPEND (CC-TI-POSSIBILITIES SYL (POP DESC)) NIL)))))
1307                        (CADDDR ITEM)))
1308               (T
1309                 #Q (LOCAL-DECLARE ((SPECIAL ARGS))
1310                      ((LAMBDA (ARGS) (BREAK CC-TI-POSSIBILITIES-LOSES T))
1311                       ITEM))
1312                 #M (BREAK FUCKUP) ))))))
1313
1314;Find the possible matches for SYL in a symbol or list of symbols or lists of ...
1315(DEFUN CC-TI-SELECT-FIELD-POSSIBILITIES (SYL SYM)
1316    (COND ((ATOM SYM)
1317           (AND (CC-TI-MATCH SYL SYM)
1318                (LIST SYM)))
1319          (T
1320           (DO ((SYM SYM (CDR SYM)) (RESULT))
1321               ((NULL SYM) RESULT)
1322              (SETQ RESULT (NCONC (CC-TI-SELECT-FIELD-POSSIBILITIES SYL (CAR SYM)) RESULT))))))
1323
1324;Match the list of characters SYL against the head of the symbol SYM.
1325(DEFUN CC-TI-MATCH (SYL SYM)
1326 (COND ((EQ SYM T) NIL)         ;T ISN'T REALLY A SYMBOL!
1327       ((DO ((SYL SYL (CDR SYL))
1328             (N 1 (1+ N)))
1329            ((NULL SYL) T)
1330         (OR (= (CAR SYL) (GETCHARN SYM N))
1331             (RETURN NIL))))))
1332
1333(DEFUN ELIMINATE-DUPLICATES (L)
1334  (COND ((NULL L) NIL)
1335        ((MEMQ (CAR L) (CDR L))
1336         (ELIMINATE-DUPLICATES (CDR L)))
1337        ((CONS (CAR L) (ELIMINATE-DUPLICATES (CDR L))))))
1338
1339(DEFUN CC-ADR-CLOSE-ENOUGH (TARGET POSSIBILITY)
1340  (OR (EQ TARGET POSSIBILITY)
1341      (AND (EQ TARGET 'RAMMO) (EQ POSSIBILITY 'RAFSO)) ;FUNC SRCS ARE OK AS M MEMORY
1342    ))
1343
1344;;;MICRO-LOADER
1345
1346(DEFVAR CC-FILE-SYMBOLS-LOADED-FROM NIL)
1347
1348(IF-FOR-MACLISP
1349(DEFUN CC-LOAD-UCODE FEXPR (L)
1350  (CC-UCODE-LOADER NIL L NIL))
1351
1352(DEFUN CC-LOAD-BOOTSTRAP FEXPR (L)              ;LOAD WITHOUT SYMBOLS AND DONT AFFECT
1353  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS L NIL)); CURRENT SYMTAB
1354
1355(DEFUN CC-LOAD-UCODE-SYMBOLS FEXPR (L)
1356  (CC-UCODE-LOADER 'LOAD-SYMBOLS L NIL))
1357
1358(DEFUN CC-COMPARE-UCODE FEXPR (L)
1359  (CC-UCODE-LOADER 'COMPARE L NIL))
1360)
1361
1362(IF-FOR-LISPM
1363(DEFUN CC-LOAD-UCODE (FILE &OPTIONAL MERGEP)
1364  (CC-UCODE-LOADER NIL FILE MERGEP)
1365  (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE))
1366
1367(DEFUN CC-LOAD-BOOTSTRAP (FILE)
1368  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL))
1369
1370(DEFUN CC-LOAD-UCODE-SYMBOLS-FOR-VERSION (VERSION)
1371  (CC-LOAD-UCODE-SYMBOLS (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; UCADR")
1372                                  ':NEW-TYPE-AND-VERSION "SYM" VERSION)))
1373
1374(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP &AUX TRUENAME)
1375  (SETQ FILE (FS:MERGE-PATHNAME-DEFAULTS FILE)
1376        TRUENAME (FUNCALL FILE ':TRUENAME))
1377  (COND ((EQ TRUENAME CC-FILE-SYMBOLS-LOADED-FROM))
1378        ((AND (NULL MERGEP)
1379              (CC-SELECT-SYMBOL-TABLE TRUENAME)))
1380        (T
1381         (CC-UCODE-LOADER 'LOAD-SYMBOLS TRUENAME MERGEP)
1382         (CC-RECORD-SYMBOL-TABLE TRUENAME))))
1383
1384(DEFUN CC-COMPARE-UCODE (FILE)
1385  (CC-UCODE-LOADER 'COMPARE FILE NIL))
1386)  ;end if for LISPM
1387
1388(DEFUN WORDEX MACRO (X)
1389  (SUBST (+ 16. (* -16. (CADR X))) 'BAR
1390    (SUBST (CADDR X) 'FOO
1391        '(BOOLE 1 177777 (LSH FOO BAR)) )))
1392
1393;(DEFUN CC-MAIN-MEMORY-BLOCK-WRITE (ADR DATA)
1394;       (CNSWDB RACMWD (WORDEX 3 DATA) (WORDEX 2 DATA) (WORDEX 1 DATA))
1395;       (CNSWDB RACPMW (WORDEX 3 ADR) (WORDEX 2 ADR) (WORDEX 1 ADR)))
1396
1397(DEFUN READ-FIXNUM (FILE)               ;HOPEFULLY FAST FIXNUM-ONLY READER, NCALL'ABLE
1398  (PROG (CH NUM SGN)
1399        (DECLARE (FIXNUM CH NUM SGN))
1400        (SETQ NUM 0 SGN 1)
1401  A     (AND (< (SETQ CH (TYI FILE)) 41)  ;IGNORE LEADING GARBAGE
1402             (GO A))
1403        (AND (> CH 177) (GO A))
1404        (COND ((= CH 55)
1405               (SETQ SGN -1))
1406              ((GO C)))
1407  B     (SETQ CH (TYI FILE))
1408  C     (COND ((= CH 137)
1409               (RETURN (* SGN (LSH NUM (READ-FIXNUM FILE)))))
1410              ((AND (> CH 57) (< CH 70))
1411               (SETQ NUM (+ (LSH NUM 3) CH -60))
1412               (GO B))
1413              ((> CH 40)
1414               (ERROR CH 'RANDOM-CHAR-IN-READ-FIXNUM 'FAIL-ACT)))
1415        (RETURN (* SGN NUM))))
1416
1417
1418
1419(DEFUN CC NIL                   ;MAIN LOOP OF CONS CONSOLE PROGRAM
1420  (PROG ((BASE 8.) (IBASE 8.) (PACKAGE (PKG-FIND-PACKAGE "CADR"))
1421         CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER
1422          CC-LAST-OPEN-REGISTER CC-LAST-VALUE-TYPED COM-CH TEM)
1423        (SETQ QF-SWAP-IN-LOOP-CHECK NIL)
1424        #M (CNSPMI)  ;FLUSH LOOKBEHIND ON CC-UNIBUS-MAP
1425        (IF-FOR-MACLISP (CC-SET-TTY-STATUS))
1426        (CC-CONSOLE-INIT)
1427        #Q (AND (EQ DBG-ACCESS-PATH 'DL11)
1428                (USER:INIT-DL11-UNIBUS-CHANNEL))
1429        (LET #Q ((STANDARD-OUTPUT CC-OUTPUT-STREAM)) #M ()
1430          (PROG ()
1431             (TERPRI)
1432             (PRINC (COND (CC-FULL-SAVE-VALID
1433                           '|CC contains saved state, type control-S to flush it.|)
1434                          (T '|Getting fresh state from machine.|)))
1435             (TERPRI)
1436             (CC-CONSOLE-STATUS-DISPLAY T)    ;dont touch machine since saved state may
1437                                              ;not be valid
1438         L0  (SETQ CC-ARG NIL)
1439             (AND (SIGNP GE (- (CAR (CURSORPOS)) CC-FIRST-STATUS-LINE))
1440                  (PROGN (CURSORPOS 'Z) (TERPRI)))
1441         L   (SETQ CC-SYL (CC-GETSYL-READ-TOKEN))
1442             (COND ((NUMBERP CC-SYL)
1443                    (GO L1))
1444                   ((EQ CC-SYL '*RUB*) ;OVER RUB-OUT
1445                    (GO ERR1))
1446                   ((EQ CC-SYL '/@)     ;VARIOUS REG ADDR SPACES + MISC COMMANDS
1447                    (GO COM))
1448                   ((EQ CC-SYL '/)     ;EXIT TO LISP
1449                    (GO X))
1450                   ((EQ CC-SYL '/_)     ;VARIOUS TYPE-OUT MODES
1451                    (GO UND))
1452                   ((EQ CC-SYL '/`)     ;VARIOUS TYPE-IN MODES
1453                    (GO IND))
1454                   ((EQ CC-SYL '/')     ;TYPE-IN OVER EXISTING FIELDS
1455                    (GO INDOV))
1456                   ((EQ CC-SYL '/.)     ;"POINT"
1457                    (SETQ CC-SYL CC-LAST-OPEN-REGISTER)
1458                    (GO L1))
1459                   ((EQ CC-SYL '/:)     ;VARIOUS SYMBOLIC COMMANDS
1460                    (GO CLN))
1461                   ((SETQ TEM (CC-LOOKUP-NAME CC-SYL))
1462                    (SETQ CC-SYL TEM)
1463                    (GO L1)))
1464            L2     (COND ((SETQ TEM (GET CC-SYL 'CC-COMMAND))
1465                          (GO COM1)))
1466            ERR   (PRIN1 CC-SYL)
1467            ERR1  (PRINC '??/ / )
1468            (GO L0)
1469
1470  L1    (COND ((NUMBERP CC-ARG)
1471                (SETQ CC-ARG (PLUS CC-ARG CC-SYL)))
1472              (T (SETQ CC-ARG CC-SYL)))
1473        (GO L)
1474
1475  COM   (SETQ COM-CH (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))
1476        (COND ((SETQ TEM (GET COM-CH 'CC-LOWEST-ADR))
1477                (COND ((NULL CC-ARG) (SETQ CC-ARG 0)))
1478                (SETQ CC-ARG (+ CC-ARG (SYMEVAL TEM)))
1479                (GO L)))
1480        (SETQ CC-SYL COM-CH)
1481        (GO L2)
1482  COM1  (SETQ CC-VAL (FUNCALL TEM CC-ARG))
1483        (COND (CC-UPDATE-DISPLAY-FLAG
1484                (CC-CONSOLE-STATUS-DISPLAY NIL)
1485                (SETQ CC-UPDATE-DISPLAY-FLAG NIL)))
1486        (COND ((NUMBERP CC-VAL)
1487                (SETQ CC-ARG CC-VAL)
1488                (GO L))
1489              (T (GO L0)))
1490
1491  UND   (SETQ CC-SYL (CC-CHAR-UPCASE (CC-GETSYL-RCH)))  ;VARIOUS TYPEOUT COMMANDS
1492        (OR CC-ARG (SETQ CC-ARG CC-LAST-VALUE-TYPED))
1493        (COND ((OR (AND (> CC-SYL 57) (< CC-SYL 72))
1494                   (= CC-SYL 55))
1495                (SETQ CC-GETSYL-UNRCH CC-SYL            ;IF DIGIT OR MINUS,
1496                      CC-SYL (CC-GETSYL-READ-TOKEN))    ;READ WHOLE NUMBER
1497                (SETQ CC-SYL (LOGAND 37 CC-SYL))        ;AND LEFT-ROTATE BY THAT
1498                (SETQ CC-ARG
1499                      (LOGIOR (LOGLDB (+ CC-SYL (CC-SHIFT (- 40 CC-SYL) 6)) CC-ARG)
1500                              (CC-SHIFT (LOGLDB (- 40 CC-SYL) CC-ARG) CC-SYL)))
1501                (AND (EQ CC-GETSYL-UNRCH-TOKEN '/ )
1502                     (SETQ CC-GETSYL-UNRCH-TOKEN '=))
1503                (GO L)))        ;N_N<SPACE> TYPES OUT, OTHERWISE IS TYPE-IN!
1504        (PRINC '/ )
1505        (OR (SETQ COM-CH (ASSQ (SETQ CC-SYL (ASCII CC-SYL))
1506                               CC-MODE-DESC-TABLE))
1507            (GO ERR))
1508        (CC-TYPE-OUT CC-ARG (CDR COM-CH) T NIL)
1509        (SETQ CC-LAST-VALUE-TYPED CC-ARG)       
1510        (PRINC '/ / )
1511        (GO L0)
1512
1513  IND   (SETQ CC-SYL (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))  ;VARIOUS TYPEIN COMMANDS
1514        (PRINC '/ )
1515        (OR (SETQ COM-CH (ASSQ CC-SYL CC-MODE-DESC-TABLE))
1516            (GO ERR))
1517        (SETQ CC-SYL (CC-TYPE-IN (CDR COM-CH) 0 NIL))
1518        (GO L1)
1519
1520  INDOV (SETQ CC-SYL (ASCII (CC-CHAR-UPCASE (CC-GETSYL-RCH))))
1521        (PRINC '|/
1522[EDIT] | )
1523        (OR (SETQ COM-CH (ASSQ CC-SYL CC-MODE-DESC-TABLE))
1524            (GO ERR))
1525        (SETQ CC-SYL (CC-TYPE-IN (CDR COM-CH) CC-LAST-VALUE-TYPED T))
1526        (GO L1)
1527
1528  X     (IF-FOR-MACLISP (CC-RESTORE-TTY-STATUS))
1529        (RETURN T)
1530
1531  CLN   (SETQ CC-SYL (CC-GETSYL-READ-TOKEN))  ;:FOOBAR ETC.
1532        (OR (SETQ TEM (GET CC-SYL 'CC-COLON-CMD))
1533            (GO ERR1))
1534        (GO COM1)
1535))))
1536
1537(DEFUN CC-CHAR-UPCASE (CHAR)
1538    (DECLARE (FIXNUM CHAR))
1539    (COND ((AND (> CHAR 140)
1540                (< CHAR 173))
1541           (LOGXOR 40 CHAR))
1542          (T CHAR)))
1543
1544(DEFUN CC-PRINT-REG-ADR-CONTENTS (ADR)
1545 (PROG (RANGE DATA PCPART)
1546        (SETQ RANGE (CC-FIND-REG-ADR-RANGE ADR))
1547        (SETQ DATA (COND ((EQ RANGE 'RAIDR)
1548                          (CC-RAID-REG (- ADR RARDRO))) ;RAIDR RANGE IS IN 10
1549                         ((CC-REGISTER-EXAMINE ADR))))
1550        (SETQ CC-LAST-VALUE-TYPED DATA)
1551        (COND ((OR (MEMQ RANGE '(C CIB)) (= ADR RAIR) (= ADR RASIR))
1552               (CC-TYPE-OUT DATA CC-UINST-DESC T NIL))
1553              ((MEMQ RANGE '(U OPC))
1554               (SETQ PCPART (\ DATA (- RACME RACMO)))
1555               (CC-PRINT-ADDRESS (+ PCPART RACMO))      ;PCP PART SYMBOLICALLY
1556               (COND ((NOT (= DATA PCPART))             ;RESIDUE, IF ANY, NUMERICALLY
1557                      (PRINC '| + |)
1558                      (PRIN1 (- DATA PCPART))))
1559               (PRINC '/ ))
1560              ((EQ RANGE 'RAIDR)
1561                (CC-PRINT-ADDRESS DATA) (PRINC '/ ))
1562              (T (PRIN1-THEN-SPACE DATA)))
1563        (PRINC '/ / )))
1564
1565;RETURNS:  NIL IF NONE FOUND CLOSER THAN 20 TO DESIRED REG ADR
1566;          SYMBOL  IF EXACT MATCH FOUND
1567;          (LIST SYMBOL DIFFERENCE)  IF ONE FOUND CLOSER THAN 20
1568
1569(DEFUN CC-FIND-REG-ADR-RANGE (REG-ADR)
1570        (COND ((< REG-ADR RACMO) 'TOO-LOW)
1571              ((< REG-ADR RACME) 'C)
1572              ((< REG-ADR RADME) 'D)
1573              ((< REG-ADR RAPBE) 'P)
1574              ((< REG-ADR RAM1E) '/1)
1575              ((< REG-ADR RAM2E) '/2)
1576              ((< REG-ADR RAAME) 'A)
1577              ((< REG-ADR RAUSE) 'U)
1578              ((< REG-ADR RAMME) 'M)
1579              ((< REG-ADR RAFSE) 'FS)
1580              ((< REG-ADR RAFDE) 'FD)
1581              ((< REG-ADR RARGE) 'CC)
1582              ((< REG-ADR RACSWE) 'CSW)
1583              ((< REG-ADR RARDRE) 'RAIDR)
1584              ((< REG-ADR RACIBE) 'CIB)
1585              ((< REG-ADR RAOPCE) 'OPC)
1586              ((< REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET) 'TOO-HIGH)
1587              ((< REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET) 'PHYSICAL)
1588              (T 'VIRTUAL)))
1589
1590(DEFPROP C RACMO CC-LOWEST-ADR)
1591(DEFPROP D RADMO CC-LOWEST-ADR)
1592(DEFPROP P RAPBO CC-LOWEST-ADR)
1593(DEFPROP /1 RAM1O CC-LOWEST-ADR)
1594(DEFPROP /2 RAM2O CC-LOWEST-ADR)
1595(DEFPROP A RAAMO CC-LOWEST-ADR)
1596(DEFPROP U RAUSO CC-LOWEST-ADR)
1597(DEFPROP M RAMMO CC-LOWEST-ADR)
1598(DEFPROP FS RAFSO CC-LOWEST-ADR)
1599(DEFPROP FD RAFDO CC-LOWEST-ADR)
1600(DEFPROP CC RARGO CC-LOWEST-ADR)
1601(DEFPROP CSW RACSWO CC-LOWEST-ADR)
1602(DEFPROP RAIDR RARDRO CC-LOWEST-ADR)
1603(DEFPROP CIB RACIBO CC-LOWEST-ADR)
1604(DEFPROP OPC RAOPCO CC-LOWEST-ADR)
1605
1606(DEFPROP C C CC-@-NAME)
1607(DEFPROP D D CC-@-NAME)
1608(DEFPROP P P CC-@-NAME)
1609(DEFPROP /1 1 CC-@-NAME)
1610(DEFPROP /2 2 CC-@-NAME)
1611(DEFPROP A A CC-@-NAME)
1612(DEFPROP U U CC-@-NAME)
1613(DEFPROP M M CC-@-NAME)
1614
1615(DEFUN CC-PRINT-ADDRESS-1 (REG-ADR WD ITEMREST)
1616    WD ITEMREST
1617    (CC-PRINT-ADDRESS REG-ADR))
1618
1619(DEFUN CC-PRINT-ADDRESS (REG-ADR)
1620  (PROG (RANGE-NAME RANGE-BASE @-NAME TEM)
1621        (SETQ RANGE-NAME (CC-FIND-REG-ADR-RANGE REG-ADR))
1622        (COND ((AND (SETQ TEM (CC-FIND-CLOSEST-SYM REG-ADR))
1623                    (OR (ATOM TEM)
1624                        (EQ RANGE-NAME 'C)
1625                        (EQ RANGE-NAME 'D)))
1626                (PRIN1 TEM))
1627              ((SETQ RANGE-BASE (GET RANGE-NAME 'CC-LOWEST-ADR))
1628                (COND ((SETQ @-NAME (GET RANGE-NAME 'CC-@-NAME))
1629                        (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE)))
1630                        (PRINC '@)
1631                        (PRIN1 @-NAME))
1632                      (T (PRIN1 RANGE-NAME)
1633                         (PRINC '/ )
1634                         (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE))))))
1635              (T (PRIN1 REG-ADR)))
1636     X  (RETURN T)
1637))
1638
1639(DEFUN CC-CONSOLE-STATUS-DISPLAY (DONT-TOUCH-MACHINE)
1640   (PROG (SAVE-CURSOR-POS PC IR)
1641        (SETQ SAVE-CURSOR-POS (CURSORPOS))
1642        (CURSORPOS CC-FIRST-STATUS-LINE 0)
1643        (CURSORPOS 'E)
1644        (PRINC '***********************************************)
1645        (TERPRI)
1646        (CC-ENTER)
1647        (PRINC 'PC=)
1648        (PRINC (SETQ PC (CC-REGISTER-EXAMINE RAPC)))
1649        (PRINC '/ / / )
1650        (SETQ IR (CC-REGISTER-EXAMINE RASIR))
1651        (PRINC 'OBUS=)
1652        (PRINC (CC-REGISTER-EXAMINE RAOBS))
1653        (PRINC '|   |)
1654        (PRIN1 (CC-FIND-CLOSEST-SYM (+ PC RACMO)))      ;PRINT SYMBOLIC PC
1655        (TERPRI)
1656        (PRINC 'IR=)
1657   ;if comming in at top level, dont print contents of M or A mem location that does
1658   ;not have symbolic name.  Problem is that examining does CC-NOOP-CLOCK which results
1659   ;in loss of state, increments PC, etc etc.
1660        (CC-TYPE-OUT IR CC-UINST-DESC T DONT-TOUCH-MACHINE)
1661        (TERPRI)
1662        (PRINC 'ERROR-STATUS)
1663        (PRINC '/ )
1664        (CC-PRINT-ERROR-STATUS  (CC-REGISTER-EXAMINE RASTS))
1665        (DBG-PRINT-STATUS)      ;PRINT UNIBUS, XBUS  PARERRS, NXM
1666        (TERPRI)
1667        (CC-RAID)
1668        (CURSORPOS (CAR SAVE-CURSOR-POS) (CDR SAVE-CURSOR-POS)) ;RESTORE CURSOR POS
1669))
1670
1671(DEFUN CC-PRINT-SET-BITS (NUM BIT-LIST)
1672  (PROG (BIT-NUM THIS-BIT-SET)
1673        (SETQ BIT-NUM 0)
1674   L    (COND ((OR (= 0 NUM)
1675                   (NULL BIT-LIST))
1676                (RETURN T)))
1677        (COND ((SETQ THIS-BIT-SET (NOT (= 0 (LOGLDB (+ (LSH BIT-NUM 6) 0001) NUM))))
1678               (SETQ NUM (LOGDPB 0 (+ (LSH BIT-NUM 6) 0001) NUM))))
1679        (COND ((NULL (CAR BIT-LIST)))
1680              ((NOT (ATOM (CAR BIT-LIST)))
1681                (COND ((FUNCALL (CAAR BIT-LIST) THIS-BIT-SET)
1682                        (PRIN1 (CADAR BIT-LIST))
1683                        (PRINC '/ ))))
1684              (THIS-BIT-SET (PRIN1 (CAR BIT-LIST))
1685                            (PRINC '/ )))
1686        (SETQ BIT-NUM (1+ BIT-NUM))
1687        (SETQ BIT-LIST (CDR BIT-LIST))
1688        (GO L)))
1689
1690
1691(DEFUN CC-STORE (REG-ADR QUAN)
1692   (COND ((EQ 'RAIDR (CC-FIND-REG-ADR-RANGE REG-ADR))
1693          (STORE (CC-RAID-REG (- REG-ADR RARDRO)) QUAN))
1694         (T (CC-REGISTER-DEPOSIT REG-ADR QUAN))))
1695
1696(DEFUN CC-RAID ()
1697  (DO ((I 0 (1+ I))
1698       (TEM)
1699       (CC-LAST-VALUE-TYPED))
1700      ((= I 8))
1701    (COND ((NOT (ZEROP (SETQ TEM (CC-RAID-REG I))))
1702           (CC-PRINT-ADDRESS TEM)
1703           (PRINC '|//   |)
1704           (CC-PRINT-REG-ADR-CONTENTS TEM)
1705           (SETQ TEM (CURSORPOS))
1706           (COND ((< (CDR TEM) 40.)
1707                  (CURSORPOS (CAR TEM) 40.))
1708                 ((TERPRI))) ))))
1709
1710(DEFPROP // CC-SLASH CC-COMMAND)
1711
1712(DEFUN CC-SLASH (ADR)
1713  (PROG NIL
1714        (COND ((NULL ADR) (RETURN NIL)))
1715        (SETQ CC-OPEN-REGISTER ADR)
1716        (SETQ CC-LAST-OPEN-REGISTER CC-OPEN-REGISTER)
1717        (PRINC '/ / / )
1718        (CC-PRINT-REG-ADR-CONTENTS ADR)
1719))
1720
1721(PUTPROP (ASCII 15) 'CC-CR 'CC-COMMAND)
1722
1723(DEFUN CC-CR (QUAN)
1724  (PROG NIL
1725        (COND ((AND QUAN CC-OPEN-REGISTER)
1726               (CC-STORE CC-OPEN-REGISTER QUAN)))
1727        (SETQ CC-OPEN-REGISTER NIL)
1728        (TERPRI)
1729))
1730
1731(PUTPROP (ASCII 12) 'CC-LF 'CC-COMMAND)
1732
1733(DEFUN CC-LF (QUAN)
1734  (PROG (TEM)
1735        (CC-CR QUAN)
1736        (CC-PRINT-ADDRESS (SETQ TEM (1+ CC-LAST-OPEN-REGISTER)))
1737        (PRINC '//)
1738        (CC-SLASH TEM) ))
1739
1740(DEFPROP ^ CC-UPAR CC-COMMAND)
1741
1742(DEFUN CC-UPAR (QUAN)
1743  (PROG (TEM)
1744        (CC-CR QUAN)
1745        (CC-PRINT-ADDRESS (SETQ TEM (1- CC-LAST-OPEN-REGISTER)))
1746        (PRINC '//)
1747        (CC-SLASH TEM) ))
1748
1749(PUTPROP (ASCII 40) 'CC-SPACE 'CC-COMMAND)
1750(PUTPROP '+ 'CC-SPACE 'CC-COMMAND)
1751
1752(DEFUN CC-SPACE (ARG)
1753   ARG)
1754
1755(PUTPROP (ASCII 14) 'CC-FORM 'CC-COMMAND)
1756
1757(DEFUN CC-FORM (QUAN)
1758        QUAN
1759        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1760        NIL)
1761
1762(DEFPROP = CC-EQUALS CC-COMMAND)
1763
1764(DEFUN CC-EQUALS (QUAN)
1765        (AND QUAN (SETQ CC-LAST-VALUE-TYPED QUAN))
1766        #M (SETQ QUAN (STATUS _))
1767        #M (SSTATUS _ NIL)
1768        (PRIN1 CC-LAST-VALUE-TYPED)
1769        #M (SSTATUS _ QUAN)
1770        (PRINC '/ / / )
1771        NIL)
1772
1773(DEFPROP G CC-GO CC-COMMAND)
1774
1775(DEFUN CC-GO (QUAN)
1776       (CC-REGISTER-DEPOSIT RASA QUAN)
1777       (SETQ CC-UPDATE-DISPLAY-FLAG T)
1778       (TERPRI)
1779        NIL)
1780
1781(DEFPROP / CC-STEP CC-COMMAND)
1782
1783(DEFUN CC-STEP (QUAN)
1784 (PROG (QN)
1785        (SETQ QN (OR QUAN 1))
1786        (CC-REGISTER-DEPOSIT RASTEP QN)
1787        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1788        (AND QUAN (TERPRI))
1789        (RETURN NIL)))
1790
1791(DEFPROP / CC-RESET CC-COMMAND)
1792
1793(DEFUN CC-RESET (QUAN)
1794        (CC-REGISTER-DEPOSIT RARS (OR QUAN 0))
1795        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1796        (TERPRI)
1797        NIL)
1798
1799(DEFPROP Q CC-Q CC-COMMAND)
1800
1801(DEFUN CC-Q (QUAN)
1802        (PLUS (OR QUAN 0) CC-LAST-VALUE-TYPED))
1803
1804(DEFPROP / CC-STOP CC-COMMAND)
1805
1806(DEFUN CC-STOP (QUAN)
1807  (SETQ CC-PASSIVE-SAVE-VALID NIL)
1808  (SETQ CC-FULL-SAVE-VALID NIL)         ;ASSURE READING FRESH STUFF FROM HARDWARE
1809  (CC-REGISTER-DEPOSIT RASTOP QUAN)
1810  (SETQ CC-UPDATE-DISPLAY-FLAG T)
1811  (TERPRI) )
1812
1813(DEFPROP / CC-PROCEED CC-COMMAND)
1814
1815(DEFUN CC-PROCEED (QUAN)
1816  (PROG (CHAR)
1817        (QF-CLEAR-CACHE NIL)    ;CLEAR PHT CACHE
1818        (CC-REGISTER-DEPOSIT RAGO (OR QUAN 0))
1819        (PRINC #Q "RUN"
1820               #M (COND ((MEMQ 'SAIL (STATUS FILEMODE TYO))
1821                         '|RUN|)
1822                        (T '--RUN--)))
1823   L    (COND (#Q (SETQ CHAR (KBD-TYI-NO-HANG)) #M (NOT (ZEROP (LISTEN))) (GO X1))
1824              ((ZEROP (CC-REGISTER-EXAMINE RAGO)) (GO X)))
1825     #Q (PROCESS-SLEEP 30.)         ;WHY WAIT AS LONG?
1826     #M (SLEEP 2)
1827        (GO L)     
1828   X1 #M(TYI)
1829        (COND ((= CHAR 203) (BREAK CC-MACHINE-RUNNING) (GO L)))
1830   X    (PRINC 'STOP)
1831        (CC-REGISTER-DEPOSIT RASTOP 0)
1832        (SETQ CC-UPDATE-DISPLAY-FLAG T)
1833        (TERPRI) ))
1834
1835(PUTPROP (INTERN (ASCII 11)) 'CC-TAB 'CC-COMMAND)
1836
1837(DEFUN CC-TAB (QUAN)
1838  (PROG (TEM)
1839        (CC-CR NIL) ;DON'T CLOBBER OPEN REGISTER
1840        (SETQ TEM (OR QUAN CC-LAST-VALUE-TYPED))
1841        (SETQ TEM (PLUS CC-REG-ADR-VIRT-MEM-OFFSET (QF-POINTER TEM)))
1842        (CC-PRINT-ADDRESS TEM)
1843        (PRINC '//)
1844        (CC-SLASH TEM) ))
1845
1846(DEFPROP FOOBAR CC-FOO-BAR CC-COMMAND)
1847
1848(DEFUN CC-FOO-BAR (QUAN)
1849  (COND ((EQUAL QUAN 105)
1850         (CC-REGISTER-DEPOSIT RARS 0)
1851         (CC-GO 1)
1852         (CC-PROCEED NIL))
1853        (T (PRINC '|FOOBAR??  |) NIL)))
1854
1855(DEFPROP / CC-REMOTE-CONSOLE CC-COMMAND)
1856
1857;REMOTE CONSOLE MODE
1858(DEFUN CC-REMOTE-CONSOLE (N)
1859 (PROG ()
1860   (QF-CLEAR-CACHE NIL)         ;CLEAR PHT CACHE
1861   (CC-REGISTER-DEPOSIT RAGO 1)
1862   (SETQ CC-UPDATE-DISPLAY-FLAG T)
1863 A (AND #M (ZEROP (LISTEN)) #Q (NOT (KBD-TYI-NO-HANG)) (GO B))
1864   (SETQ N (TYI))
1865   (AND (= N 23) (GO Y))
1866   (AND (< N 40) (TYO N))
1867   (AND (= N 15) (TYO 12))   ;NEWIO IS FUCKED UP
1868   (CC-REGISTER-DEPOSIT RARCON N)
1869   (GO A)
1870
1871 B (SETQ N (CC-REGISTER-EXAMINE RARCON))
1872   (OR (ZEROP N) (GO D))
1873   (AND (ZEROP (CC-REGISTER-EXAMINE RAGO)) (GO X))
1874   (SLEEP 1)
1875   (GO A)
1876
1877 C (AND (ZEROP (SETQ N (CC-REGISTER-EXAMINE RARCON)))
1878        (GO A))
1879 D (TYO N)
1880   (AND (= N 15) (TYO 12))   ;NEWIO IS FUCKED UP
1881   (GO C)
1882 X (PRINC '|/
1883Machine Stopped/
1884|)
1885 Y (CC-REGISTER-DEPOSIT RASTOP 0)
1886   (SETQ CC-UPDATE-DISPLAY-FLAG T)
1887))
1888
1889;;;HIGHER LEVEL STUFF
1890
1891(DEFPROP AREAS CC-DESCRIBE-AREAS CC-COLON-CMD)
1892
1893(DEFUN CC-REGISTER-EXAMINE-FIXNUM (ADR)
1894  (LET ((CONTENTS (CC-REGISTER-EXAMINE ADR)))
1895    (OR (= (LOGLDB %%Q-DATA-TYPE CONTENTS) DTP-FIX)
1896        (ERROR (LIST ADR CONTENTS) 'SHOULD-BE-Q-FIXNUM 'FAIL-ACT))
1897    (LOGAND 77777777 CONTENTS) ))
1898
1899(DEFUN CC-REGISTER-EXAMINE-PTR (ADR)
1900  (LOGAND 77777777 (CC-REGISTER-EXAMINE ADR)))
1901
1902(DEFUN CC-SYMBOLIC-EXAMINE-REGISTER (REG)
1903  (LET ((ADR (CC-LOOKUP-NAME REG)))
1904    (COND ((NULL ADR)
1905           (PRINT REG) (PRINC '| is undefined.|) (TERPRI)
1906           0)
1907          (T (CC-REGISTER-EXAMINE ADR)))))
1908
1909(DEFUN CC-SYMBOLIC-DEPOSIT-REGISTER (REG VAL)
1910  (LET ((ADR (CC-LOOKUP-NAME REG)))
1911    (COND ((NULL ADR)
1912           (PRINT REG) (PRINC '| is undefined.|) (TERPRI))
1913          (T (CC-REGISTER-DEPOSIT ADR VAL)))))
1914
1915(DEFUN CC-DESCRIBE-AREAS (IGNORE)
1916  (TERPRI)
1917  (LET ((A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
1918        (A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
1919        (A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
1920        (A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))
1921
1922        (R-O (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
1923        (R-L (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH))
1924        (R-B (QF-INITIAL-AREA-ORIGIN 'REGION-BITS))
1925        (R-FP (QF-INITIAL-AREA-ORIGIN 'REGION-FREE-POINTER))
1926        (R-GCP (QF-INITIAL-AREA-ORIGIN 'REGION-GC-POINTER))
1927        (R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)))
1928   (DO ((AREA 0 (1+ AREA))
1929        (NAREAS 0) (BITS) (A-NAME))
1930       ((= AREA SIZE-OF-AREA-ARRAYS) (PRINC '|/
1931Number of active areas = |) (PRINC NAREAS) (TERPRI) )
1932       (SETQ A-NAME (QF-MEM-READ (+ A-N AREA)))
1933       (COND ((AND (= (LOGLDB %%Q-DATA-TYPE A-NAME) DTP-SYMBOL)
1934                   (NOT (ZEROP (LOGLDB %%Q-POINTER A-NAME))))
1935                (AND (SIGNP GE (- (CAR (CURSORPOS)) CC-FIRST-STATUS-LINE))
1936                     (PROGN (PRINC '**MORE**) (TYI)
1937                            (CURSORPOS 0 0) (CURSORPOS 'L)))
1938                (SETQ NAREAS (1+ NAREAS))
1939                (PRIN1 AREA)            ;AREA NUMBER
1940                (TYO #M 11 #Q 211)
1941                (CC-Q-PRINT-TOPLEV A-NAME)  ;AREA-NAME
1942                (TYO #M 11 #Q 211)
1943                (PRINC '|Region-size |)
1944                (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-RS AREA)))
1945                (PRINC '| Maximum-size |)
1946                (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ A-MS AREA)))
1947                (DO ((RN (LOGLDB %%Q-POINTER (QF-MEM-READ (+ A-RL AREA)))
1948                         (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-LT RN)))))
1949                     ((NOT (ZEROP (LOGAND 1_23. RN)))
1950                      (COND ((NOT (= AREA (LOGAND RN 777777)))
1951                             (PRINC '|Region thread not linked back to AREA!!|))))
1952                   (TERPRI)
1953                   (PRINC '|   R |)
1954                   (PRINC RN)
1955                   (PRINC '|: Origin |)
1956                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-O RN))))
1957                   (PRINC '| Length |)
1958                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-L RN))))
1959                   (PRINC '| Free-Ptr |)
1960                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-FP RN))))
1961                   (PRINC '| GC-Ptr |)
1962                   (PRINC (LOGLDB %%Q-POINTER (QF-MEM-READ (+ R-GCP RN))))
1963                   (PRINC '| |)
1964                   (SETQ BITS (QF-MEM-READ (+ R-B RN)))
1965                   (PRINC (NTH (LOGLDB %%REGION-REPRESENTATION-TYPE BITS)
1966                               '(LIST STRUC 2 3)))
1967                   (PRINC '| |)
1968                   (PRINC (NTH (LOGLDB %%REGION-SPACE-TYPE BITS)
1969                               '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6
1970                                 STATIC FIXED EXTRA-PDL COPY 15 16 17))))
1971                (TERPRI))))))
1972
1973
1974(DEFUN (ATOM CC-COLON-CMD) (TEM)
1975  (SETQ CC-GETSYL-UNRCH NIL CC-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
1976  (SETQ TEM (READ))     ;GET NAME OF ATOM USING LISP SYNTAX
1977  (TERPRI)
1978  (SETQ TEM (QF-SYMBOL TEM))
1979  (COND ((< TEM 0)
1980         (PRINC '|Not found.|)
1981         (TERPRI))
1982        (T (CC-DESCRIBE-THIS-ATOM TEM)))
1983  (TERPRI)
1984  NIL)
1985
1986(DEFUN CC-DESCRIBE-THIS-ATOM (ADR)
1987  (PRINT 'LOCATION)
1988  (PRIN1 (SETQ ADR (QF-POINTER ADR)))
1989  (PRINT 'VALUE)
1990  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (1+ ADR)))
1991  (PRINT 'FUNCTION)
1992  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 2)))
1993  (PRINT 'PLIST)
1994  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 3)))
1995  (PRINT 'PACKAGE)
1996  (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ ADR 4)))
1997  (TERPRI))
1998
1999(DEFPROP AREA CC-WHICH-AREA CC-COLON-CMD)
2000(DEFUN CC-WHICH-AREA (ARG)
2001   (SETQ ARG (OR ARG CC-LAST-VALUE-TYPED))
2002   (LET ((AREA-NUM (QF-AREA-NUMBER-OF-POINTER ARG)))
2003      (PRINC '|Area # = |) (PRINC AREA-NUM) (PRINC '| |)
2004      (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'AREA-NAME)
2005                                         AREA-NUM)))
2006      (TERPRI)))
2007
2008(DEFPROP MAPS CC-MAPS CC-COLON-CMD)
2009(DEFUN CC-MAPS (ARG)
2010   (SETQ ARG (OR ARG CC-LAST-VALUE-TYPED))
2011   (PROG (L1MAPADR L1VAL L2MAPADR L2BITS L2VAL)
2012         (SETQ L1MAPADR (LOGLDB 1513 ARG))
2013         (SETQ L2BITS (LOGLDB 0805 ARG))
2014         (PRINC L1MAPADR) (PRINC '|@1// |)
2015          (PRIN1-THEN-SPACE (SETQ L1VAL (CC-REGISTER-EXAMINE (+ RAM1O L1MAPADR))))
2016         (PRINC (SETQ L2MAPADR (+ (CC-SHIFT L1VAL 5) L2BITS))) (PRINC '|@2// |)
2017          (PRIN1-THEN-SPACE (SETQ L2VAL (CC-REGISTER-EXAMINE (+ RAM2O L2MAPADR))))
2018         (TERPRI)))
2019
2020;;; STACK PRINTING STUFF
2021
2022(DECLARE (SPECIAL CC-STACK-VIRTUAL-ADDRESS-MODE CC-STACK-M-AP CC-STACK-PP
2023        CC-STACK-SPDL-FRAME-EXISTS 
2024        CC-STACK-A-QLBNDP CC-STACK-A-QLPDLO
2025        CC-STACK-A-QLBNDO CC-STACK-CURRENT-FRAME-TYPE
2026        CC-STACK-CURRENT-FRAME-CALL-STATE CC-STACK-CURRENT-FRAME-EXIT-STATE
2027        CC-STACK-CURRENT-FRAME-ENTRY-STATE CC-STACK-CURRENT-FRAME-FCTN
2028        CC-STACK-PREVIOUS-ACTIVE-FRAME
2029        CC-STACK-PREVIOUS-OPEN-FRAME CC-STACK-A-QCSTKG
2030        CC-STACK-MACRO-PC CC-STACK-USTACK-DATA))
2031
2032(DECLARE (SPECIAL %%LP-EXS-EXIT-PC
2033                %%LP-CLS-ADI-PRESENT
2034                %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2035                %%LP-CLS-DELTA-TO-OPEN-BLOCK
2036                %%LP-EXS-BINDING-BLOCK-PUSHED
2037                %%LP-EXS-MICRO-STACK-SAVED
2038                %%LP-ENS-NUM-ARGS-SUPPLIED))
2039
2040;MODE = NIL -> USE PDL BUFFER ADDRESSES AND ONLY PRINT WHATS IN P.B.
2041;     = T   -> USE VIRTUAL ADDRESSES  (NOT IMPLEMENTED NOW)
2042(DEFUN CC-STACK-SET-VARS-FROM-MACHINE (MODE)
2043  (PROG (PDL-BUFFER-HEAD PDL-BUFFER-VIRTUAL-ADDRESS) 
2044        (SETQ CC-STACK-VIRTUAL-ADDRESS-MODE MODE)
2045        (SETQ CC-STACK-USTACK-DATA (CC-GET-USTACK-DATA-LIST))
2046        (SETQ CC-STACK-M-AP (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2047              CC-STACK-PP (CC-SYMBOLIC-EXAMINE-REGISTER 'PP)
2048              CC-STACK-A-QLBNDP (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDP)
2049              CC-STACK-A-QLBNDO (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLBNDO) )
2050        (COND ((NULL MODE)
2051                (SETQ CC-STACK-A-QLPDLO (CC-SYMBOLIC-EXAMINE-REGISTER
2052                                                'A-PDL-BUFFER-HEAD))
2053                (SETQ CC-STACK-M-AP (+ CC-STACK-M-AP RAPBO))
2054                (SETQ CC-STACK-PP (+ CC-STACK-PP RAPBO))
2055                (SETQ CC-STACK-A-QLPDLO (+ CC-STACK-A-QLPDLO RAPBO)))
2056              (T (SETQ CC-STACK-A-QLPDLO (CC-SYMBOLIC-EXAMINE-REGISTER 'A-QLPDLO))
2057                 (SETQ PDL-BUFFER-HEAD (LOGLDB %%Q-POINTER
2058                        (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-HEAD)))
2059                 (SETQ PDL-BUFFER-VIRTUAL-ADDRESS (LOGLDB %%Q-POINTER
2060                        (CC-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS)))
2061                 (SETQ CC-STACK-M-AP (+ PDL-BUFFER-VIRTUAL-ADDRESS
2062                        (LOGAND 1777 (- CC-STACK-M-AP PDL-BUFFER-HEAD))))
2063                 (SETQ CC-STACK-PP (+ PDL-BUFFER-VIRTUAL-ADDRESS
2064                        (LOGAND 1777 (- CC-STACK-PP PDL-BUFFER-HEAD))))
2065                ))   ;RELOCATE AP, ETC TO VIRTUAL ADDRESSES
2066        (CC-STACK-CURRENT-FRAME-SETUP MODE)
2067        (SETQ CC-STACK-SPDL-FRAME-EXISTS NIL)
2068        (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2069                (SETQ CC-STACK-SPDL-FRAME-EXISTS
2070                         (NOT (ZEROP (LOGLDB %%M-FLAGS-QBBFL
2071                                             (CC-SYMBOLIC-EXAMINE-REGISTER
2072                                                        'M-FLAGS)))))))
2073        (SETQ CC-STACK-MACRO-PC
2074              (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
2075))
2076
2077;INDEX BACK TO PREVIOUS STACK FRAME
2078(DEFUN CC-STACK-NEXT-FRAME-SETUP (MODE)
2079  (PROG ()
2080        (COND ((NULL CC-STACK-PREVIOUS-ACTIVE-FRAME) (RETURN NIL)))
2081        (SETQ CC-STACK-M-AP CC-STACK-PREVIOUS-ACTIVE-FRAME)
2082        (CC-STACK-CURRENT-FRAME-SETUP MODE)
2083        (SETQ CC-STACK-USTACK-DATA NIL)
2084        (COND ((NOT (ZEROP (LOGLDB %%LP-EXS-MICRO-STACK-SAVED
2085                                   CC-STACK-CURRENT-FRAME-EXIT-STATE)))
2086               (SETQ CC-STACK-USTACK-DATA (CC-STACK-XFER-USTACK))))
2087        (SETQ CC-STACK-SPDL-FRAME-EXISTS
2088              (LOGLDB %%LP-EXS-BINDING-BLOCK-PUSHED CC-STACK-CURRENT-FRAME-EXIT-STATE))
2089        (RETURN T)
2090))
2091
2092
2093(DEFUN CC-STACK-XFER-USTACK ()
2094  (PROG (DATA LST)
2095        (SETQ CC-STACK-USTACK-DATA NIL)
2096   L    (COND ((NOT (> CC-STACK-A-QLBNDP CC-STACK-A-QLBNDO))
2097                (PRINT 'BIND-STACK-EXHAUSTED-DURING-USTACK-XFER)
2098                (RETURN NIL)))
2099        (SETQ LST (CONS (SETQ DATA (QF-MEM-READ CC-STACK-A-QLBNDP))
2100                        LST))
2101        (SETQ CC-STACK-A-QLBNDP (1- CC-STACK-A-QLBNDP))
2102        (COND ((= 0 (LOGLDB %%Q-FLAG-BIT DATA)) ;NFLAGB
2103               (GO L)))
2104        (RETURN LST)
2105))
2106
2107;SET UP VARS TO FRAME CC-STACK-M-AP POINTS
2108(DEFUN CC-STACK-CURRENT-FRAME-SETUP (MODE)
2109  (PROG (TEM)
2110    (COND ((NULL MODE)
2111        (SETQ CC-STACK-CURRENT-FRAME-CALL-STATE
2112                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 3)))
2113        (SETQ CC-STACK-CURRENT-FRAME-EXIT-STATE
2114                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 2)))
2115        (SETQ CC-STACK-CURRENT-FRAME-ENTRY-STATE
2116                (CC-REGISTER-EXAMINE (- CC-STACK-M-AP 1)))
2117        (SETQ CC-STACK-CURRENT-FRAME-FCTN (CC-REGISTER-EXAMINE CC-STACK-M-AP)) )
2118    (T  (SETQ CC-STACK-CURRENT-FRAME-CALL-STATE
2119                (CC-MEM-READ (- CC-STACK-M-AP 3)))
2120        (SETQ CC-STACK-CURRENT-FRAME-EXIT-STATE
2121                (CC-MEM-READ (- CC-STACK-M-AP 2)))
2122        (SETQ CC-STACK-CURRENT-FRAME-ENTRY-STATE
2123                (CC-MEM-READ (- CC-STACK-M-AP 1)))
2124        (SETQ CC-STACK-CURRENT-FRAME-FCTN (CC-MEM-READ CC-STACK-M-AP)) ))
2125
2126        (SETQ CC-STACK-CURRENT-FRAME-TYPE (NTH (LOGLDB %%Q-DATA-TYPE
2127                                                       CC-STACK-CURRENT-FRAME-FCTN)
2128                                                Q-DATA-TYPES))
2129        (SETQ TEM (LOGLDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2130                          CC-STACK-CURRENT-FRAME-CALL-STATE))
2131        (SETQ CC-STACK-PREVIOUS-ACTIVE-FRAME
2132                (COND ((= TEM 0) NIL)
2133                      (T (- CC-STACK-M-AP TEM)) ))
2134        (SETQ TEM (LOGLDB %%LP-CLS-DELTA-TO-OPEN-BLOCK
2135                          CC-STACK-CURRENT-FRAME-CALL-STATE))
2136        (SETQ CC-STACK-PREVIOUS-OPEN-FRAME
2137                (- CC-STACK-M-AP TEM))
2138        (SETQ CC-STACK-MACRO-PC (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2139                                       (LOGLDB %%LP-EXS-EXIT-PC
2140                                               CC-STACK-CURRENT-FRAME-EXIT-STATE))
2141                                      (T -1)))
2142))
2143
2144(DEFUN CC-STACK-SPACE-BIND-STACK NIL
2145 (PROG (TEM)
2146        (COND ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2147                (COND (CC-STACK-SPDL-FRAME-EXISTS
2148                        (CC-STACK-SPACE-BINDING-BLOCK))))
2149              ((EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-U-ENTRY)
2150                (GO L1)))
2151   X    (RETURN T)
2152   L1   (SETQ TEM CC-STACK-USTACK-DATA)
2153   L2   (COND ((NULL TEM) (GO X))
2154              ((NOT (ZEROP (LOGAND (CAR CC-STACK-USTACK-DATA) 40000))) ;PPBSPC
2155                (CC-STACK-SPACE-BINDING-BLOCK)))
2156        (SETQ TEM (CDR TEM))
2157        (GO L2)))
2158
2159(DEFUN CC-STACK-SPACE-BINDING-BLOCK NIL
2160  (PROG (BOUND-LOC-POINTER PREV-CONTENTS)
2161   L    (COND ((NOT (> CC-STACK-A-QLBNDP CC-STACK-A-QLBNDO))
2162               (RETURN T)))
2163        (SETQ BOUND-LOC-POINTER (QF-MEM-READ CC-STACK-A-QLBNDP))
2164        (COND ((NOT (= DTP-LOCATIVE (LOGLDB %%Q-DATA-TYPE BOUND-LOC-POINTER)))
2165               (PRINT 'BOUND-LOC-POINTER-NOT-LOCATIVE)))
2166        (SETQ PREV-CONTENTS (QF-MEM-READ (1- CC-STACK-A-QLBNDP)))
2167        (SETQ CC-STACK-A-QLBNDP (- CC-STACK-A-QLBNDP 2))
2168        (COND ((NOT (= 0 (LOGLDB %%Q-FLAG-BIT PREV-CONTENTS)))  ;NFLAGB
2169               (GO L)))
2170        (RETURN T)
2171))
2172
2173(DEFPROP STKP CC-PRINT-PDL CC-COLON-CMD)
2174
2175(DEFUN CC-PRINT-PDL (CNT) (CC-PRINT-PDL-1 CNT T))
2176
2177(DEFPROP BAKTRACE CC-BAKTRACE CC-COLON-CMD)
2178(DEFPROP BACKTRACE CC-BAKTRACE CC-COLON-CMD)
2179
2180(DEFUN CC-BAKTRACE (CNT) (CC-PRINT-PDL-1 CNT NIL))
2181
2182(DEFUN CC-PRINT-PDL-1 (CNT PRINT-ARGS-FLAG)     ;ARG IS NUMBER OF BLOCKS TO PRINT
2183 (PROG (MODE)
2184        (SETQ MODE T)
2185        (TERPRI)
2186        (COND ((NULL CNT) (SETQ CNT 100005))
2187              ((< CNT 0) (SETQ CNT (- 0 CNT)) (SETQ MODE NIL))) ;NEG NUMBER OF BLOCKS DOESNT
2188                        ;GO THRU PAGING HAIR, ETC.
2189        (CC-STACK-SET-VARS-FROM-MACHINE MODE)
2190    L   (CC-STACK-PRINT-STACK-FRAME MODE PRINT-ARGS-FLAG)
2191        (COND ((< (SETQ CNT (1- CNT)) 0) (RETURN T))
2192              (#M (NOT (ZEROP (LISTEN)))
2193               #Q (KBD-TYI-NO-HANG)
2194               (RETURN 'LISTEN)))
2195        (CC-STACK-SPACE-BIND-STACK)
2196        (COND ((NULL (CC-STACK-NEXT-FRAME-SETUP MODE)) (RETURN T)))
2197        (GO L)
2198))
2199
2200(DEFUN CC-STACK-PRINT-STACK-FRAME (MODE PRINT-ARGS-FLAG)
2201  (PROG (ADR CNT) ;TEM ADL-POINTER ARG-DESC VAR-NAME SV-LIST-POINTER
2202        (DECLARE (FIXNUM ADR CNT)) ;TEM ADL-POINTER ARG-DESC SV-LIST-POINTER
2203        (PRIN1-THEN-SPACE CC-STACK-M-AP)
2204        (CC-Q-PRINT-TOPLEV CC-STACK-CURRENT-FRAME-FCTN)
2205        (PRINC '/[)
2206        (PRIN1 (LOGLDB %%LP-EXS-EXIT-PC CC-STACK-CURRENT-FRAME-EXIT-STATE))
2207        (PRINC '/])
2208        (COND ((NULL PRINT-ARGS-FLAG) (TERPRI) (RETURN T)))
2209        (SETQ ADR (1+ CC-STACK-M-AP))
2210        (SETQ CNT (LOGLDB %%LP-ENS-NUM-ARGS-SUPPLIED
2211                          CC-STACK-CURRENT-FRAME-ENTRY-STATE))
2212;       (COND ((AND (EQ CC-STACK-CURRENT-FRAME-TYPE 'DTP-FEF-POINTER)
2213;                   (NOT (= 0 (LOGLDB-FROM-FIXNUM %%FEFH-SV-BIND
2214;                                    (QF-MEM-READ (LOGLDB-FROM-FIXNUM %%Q-POINTER
2215;                                                         CC-STACK-CURRENT-FRAME-FCTN))))))
2216;               (SETQ ADL-POINTER (LOGLDB-FROM-FIXNUM %%Q-POINTER
2217;                  (+ CC-STACK-CURRENT-FRAME-FCTN (LOGLDB-FROM-FIXNUM %%FEFHI-MS-ARG-DESC-ORG
2218;                     (QF-MEM-READ (LOGLDB-FROM-FIXNUM %%Q-POINTER
2219;                       (+ CC-STACK-CURRENT-FRAME-FCTN %FEFHI-MISC)))))))
2220;               (SETQ SV-LIST-POINTER (LOGLDB-FROM-FIXNUM %%Q-POINTER
2221;                  (+ CC-STACK-CURRENT-FRAME-FCTN %FEFHI-SPECIAL-VALUE-CELL-PNTRS)))))
2222    L   (COND ((= CNT 0) (TERPRI) (RETURN T)))
2223        (PRINC '/ )
2224;       (COND (ADL-POINTER
2225;               (SETQ ARG-DESC (QF-MEM-READ ADL-POINTER))
2226;               (SETQ VAR-NAME NIL)
2227;               (SETQ ADL-POINTER
2228;                 (+ ADL-POINTER
2229;                    1
2230;                    (COND ((= 0 (LOGLDB-FROM-FIXNUM %%FEF-NAME-PRESENT ARG-DESC)) 0)
2231;                           (T (SETQ VAR-NAME (QF-MEM-READ (+ ADL-POINTER 1))) 1))
2232;                    (COND ((OR (= (SETQ TEM (LOGLDB-FROM-FIXNUM %%FEF-INIT-OPTION ARG-DESC))
2233;                                  FEF-INI-PNTR)
2234;                               (= TEM FEF-INI-C-PNTR)
2235;                               (= TEM FEF-INI-OPT-SA)
2236;                               (= TEM FEF-INI-EFF-ADR))
2237;                             1)
2238;                           (T 0)))) ))
2239        (CC-Q-PRINT-TOPLEV (COND ((NULL MODE) (CC-REGISTER-EXAMINE ADR))
2240                                 (T (CC-MEM-READ ADR))))
2241        (SETQ CNT (1- CNT) ADR (1+ ADR))
2242        (GO L)
2243 ))
2244
2245(DEFUN CC-GET-USTACK-DATA-LIST NIL   ;RETURNS A LIST OF CONTENTS OF USTACK
2246   (PROG (USP DATA)                  ; CAR OF RESULT WOULD BE POPJ ED TO FIRST
2247        (SETQ USP (CC-SYMBOLIC-EXAMINE-REGISTER 'USP))
2248    L   (COND ((NOT (> USP 0)) (RETURN (NREVERSE DATA))))
2249        (SETQ DATA (CONS (CC-REGISTER-EXAMINE (+ USP RAUSO))
2250                         DATA))
2251        (SETQ USP (1- USP))
2252        (GO L)))
2253
2254
2255;;; BREAKPOINTS
2256
2257(DEFPROP HERE CC-HERE CC-COLON-CMD)
2258
2259(DEFUN CC-HERE (QUAN)
2260  (SETQ CC-REMOTE-CONSOLE-MODE T)
2261  QUAN)
2262
2263(DEFPROP THERE CC-THERE CC-COLON-CMD)
2264
2265(DEFUN CC-THERE (QUAN)
2266  (SETQ CC-REMOTE-CONSOLE-MODE NIL)
2267  QUAN)
2268
2269(DEFPROP LISTB CC-LIST-BREAKPOINTS CC-COLON-CMD)
2270
2271(DEFUN CC-LIST-BREAKPOINTS (QUAN)
2272  QUAN
2273  (AND CC-BREAKPOINT-LIST (PRINT 'PERMANENT-BREAKPOINTS))
2274  (DO X CC-BREAKPOINT-LIST (CDR X) (NULL X)
2275    (TERPRI) (CC-PRINT-ADDRESS (CAR X)))
2276  (AND CC-TEMPORARY-BREAKPOINT-LIST (PRINT 'TEMPORARY-BREAKPOINTS))
2277  (DO X CC-TEMPORARY-BREAKPOINT-LIST (CDR X) (NULL X)
2278    (TERPRI) (CC-PRINT-ADDRESS (CDR X)))
2279  (AND (NULL CC-BREAKPOINT-LIST) (NULL CC-TEMPORARY-BREAKPOINT-LIST)
2280       (PRINT 'NONE))
2281  (CC-CR NIL))
2282
2283(DEFPROP B CC-SET-PERM-BKPT CC-COLON-CMD)
2284
2285(DEFUN CC-SET-PERM-BKPT (QUAN)
2286  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) T)
2287  (CC-CR NIL))
2288
2289(DEFPROP TB CC-SET-TEMP-BKPT CC-COLON-CMD)
2290
2291(DEFUN CC-SET-TEMP-BKPT (QUAN)
2292  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) NIL)
2293  (CC-CR NIL))
2294
2295(DEFPROP TBP CC-SET-TEMP-BKPT-CONTIN CC-COLON-CMD)
2296
2297(DEFUN CC-SET-TEMP-BKPT-CONTIN (QUAN)
2298  (CC-SET-BREAKPOINT (OR QUAN CC-LAST-OPEN-REGISTER) NIL)
2299  (CC-CONTIN NIL))
2300
2301(DEFPROP G CC-LOAD-ADDR-CONTIN CC-COLON-CMD)
2302
2303(DEFUN CC-LOAD-ADDR-CONTIN (QUAN)
2304  (CC-GO 1)
2305  (CC-CONTIN QUAN))
2306
2307(DEFPROP P CC-CONTIN CC-COLON-CMD)
2308
2309(DEFUN CC-CONTIN (QUAN)
2310  QUAN
2311  (COND (CC-REMOTE-CONSOLE-MODE
2312         (CC-REMOTE-CONSOLE 0))
2313        (T (CC-PROCEED NIL)))
2314  (COND ((NOT (NULL CC-TEMPORARY-BREAKPOINT-LIST))
2315         (MAPC 'CC-UNSET-BREAKPOINT CC-TEMPORARY-BREAKPOINT-LIST)
2316         (PRINT '(TEMPORARY-BREAKPOINTS-REMOVED))))
2317  (CC-CR NIL))
2318
2319(DEFPROP UB CC-UNSET-BKPT CC-COLON-CMD)
2320
2321(DEFUN CC-UNSET-BKPT (LOC)
2322  (OR LOC (SETQ LOC CC-LAST-OPEN-REGISTER))
2323  (COND ((OR (MEMBER LOC CC-BREAKPOINT-LIST)
2324             (MEMBER LOC CC-TEMPORARY-BREAKPOINT-LIST))
2325           (CC-UNSET-BREAKPOINT (OR LOC CC-LAST-OPEN-REGISTER)))
2326        (T (PRINT 'NO-BREAKPOINT-AT)
2327           (CC-PRINT-ADDRESS LOC)))
2328  (CC-CR NIL))
2329
2330(DEFPROP UAB CC-UNSET-ALL-BKPTS CC-COLON-CMD)
2331 
2332(DEFUN CC-UNSET-ALL-BKPTS (QUAN)
2333  QUAN
2334  (MAPC 'CC-UNSET-BREAKPOINT CC-BREAKPOINT-LIST)
2335  (MAPC 'CC-UNSET-BREAKPOINT CC-TEMPORARY-BREAKPOINT-LIST)
2336  (CC-CR NIL))
2337
2338(DEFUN CC-SET-BREAKPOINT (LOC PERMANENT)
2339  (PROG (CONTENTS MF)
2340    (OR (EQ 'C (CC-FIND-REG-ADR-RANGE LOC))
2341        (RETURN (PRINT 'BKPT-NOT-IN-C-MEM)))
2342    (SETQ CONTENTS (CC-REGISTER-EXAMINE LOC))
2343    (SETQ MF (LOGLDB 1202 CONTENTS))
2344    (COND ((= MF 0))
2345          ((= MF 1) (PRINT '(WARNING/, BKPT ALREADY SET)))
2346          (T (RETURN (PRINT '(SORRY/, MF FIELD ALREADY IN USE THIS INSTRUCTION)))))
2347    (CC-REGISTER-DEPOSIT LOC (LOGDPB 1 1202 CONTENTS))
2348    (COND (PERMANENT
2349           (SETQ CC-BREAKPOINT-LIST (CONS LOC CC-BREAKPOINT-LIST)))
2350          ((SETQ CC-TEMPORARY-BREAKPOINT-LIST (CONS LOC CC-TEMPORARY-BREAKPOINT-LIST))))
2351   ))
2352
2353(DEFUN CC-UNSET-BREAKPOINT (LOC)
2354  (PROG (CONTENTS MF)
2355    (OR (EQ 'C (CC-FIND-REG-ADR-RANGE LOC))
2356        (RETURN (PRINT 'BKPT-NOT-IN-C-MEM)))
2357    (SETQ CONTENTS (CC-REGISTER-EXAMINE LOC))
2358    (SETQ MF (LOGLDB 1202 CONTENTS))
2359    (COND ((NOT (= MF 1))
2360           (PRINT 'BREAKPOINT-CLOBBERED)
2361           (CC-PRINT-ADDRESS LOC))
2362          (T (CC-REGISTER-DEPOSIT LOC (LOGDPB 0 1202 CONTENTS))))
2363    (SETQ CC-BREAKPOINT-LIST (DELETE LOC CC-BREAKPOINT-LIST))
2364    (SETQ CC-TEMPORARY-BREAKPOINT-LIST (DELETE LOC CC-TEMPORARY-BREAKPOINT-LIST))
2365   ))
2366
2367(DEFPROP CHECK-MAP CC-CHECK-MAP CC-COLON-CMD)
2368
2369(ARRAY CC-LEVEL-1-MAP-FREQUENCIES FIXNUM 32.)
2370(ARRAY CC-LEVEL-1-REVERSE-MAP FIXNUM 32.)
2371
2372(DEFUN CC-CHECK-MAP (TEM)
2373 (PROG (NUM-CHECKED-OK L1-MAP PRINT-MAP-FREQS)
2374  (SETQ NUM-CHECKED-OK 0)
2375  (DO I 0 (1+ I) (= I 32.)
2376      (STORE (CC-LEVEL-1-MAP-FREQUENCIES I) 0))
2377  (DO ((ADR RAM1O (1+ ADR)))
2378      ((= ADR RAM1E))
2379    (SETQ L1-MAP (CC-REGISTER-EXAMINE ADR))
2380    (COND ((OR (< L1-MAP 0) (> L1-MAP 31.))
2381           (PRINT (LIST 'BAD-LEVEL-1-MAP-VALUE ADR L1-MAP)))
2382          (T
2383            (STORE (CC-LEVEL-1-MAP-FREQUENCIES L1-MAP)
2384                   (SETQ TEM (1+ (CC-LEVEL-1-MAP-FREQUENCIES L1-MAP))))
2385            (COND ((AND (NOT (= L1-MAP 37))      ;NO LEVEL 1 MAP ENTRYS SHOULD BE DUPLICATED
2386                        (NOT (= TEM 1)))         ; EXCEPT 37
2387                   (FORMAT T "~%TRIGGERED ON L1-MAP ~O, FREQ ~O" L1-MAP TEM)
2388                   (SETQ PRINT-MAP-FREQS T)))
2389            (STORE (CC-LEVEL-1-REVERSE-MAP L1-MAP)
2390                   (- ADR RAM1O)))))
2391  (COND (PRINT-MAP-FREQS
2392          (DO ((I 0 (1+ I)))
2393              ((= I 32.))
2394            (PRINT (LIST 'LEVEL-1-MAP-VALUE I 'APPEARS (CC-LEVEL-1-MAP-FREQUENCIES I))))))
2395  (DO ((I 0 (1+ I))
2396       (NOT-37S 0))
2397      ((= I 31.)
2398       (PRINT (LIST 'NOT-37S NOT-37S)))
2399    (SETQ TEM (CC-LEVEL-1-MAP-FREQUENCIES I))
2400    (SETQ NOT-37S (+ NOT-37S TEM))
2401    (COND ((ZEROP TEM)
2402           (PRINT (LIST 'LEVEL-2-MAP-BLOCK I 'NOT-USED))
2403           (GO E))
2404          ((> TEM 1)
2405           (PRINT (LIST 'LEVEL-2-MAP-BLOCK I 'USED TEM 'TIMES))))
2406    (SETQ NUM-CHECKED-OK
2407          (+ (CC-CHECK-LEVEL-2-BLOCK (CC-SHIFT (CC-LEVEL-1-REVERSE-MAP I) 13.)
2408                                     I)
2409             NUM-CHECKED-OK))
2410    E)
2411  (PRINT (LIST NUM-CHECKED-OK 'MAP-ENTRIES-CHECKED-OK))
2412  (RETURN NIL)))
2413
2414(DECLARE (SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE))
2415
2416(DECLARE (SPECIAL A-MEMORY-VIRTUAL-BASE-ADDRESS))
2417
2418(SETQ A-MEMORY-VIRTUAL-BASE-ADDRESS (DPB (LSH A-MEMORY-VIRTUAL-ADDRESS -27)
2419                                         2701
2420                                         (DPB A-MEMORY-VIRTUAL-ADDRESS 0027 0)))
2421
2422(DEFUN CC-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
2423 (PROG (L2M PHT-ADR PHT-VALUE VIR-ADR NUM-CHECKED-OK L2MAP-SA)
2424   (SETQ NUM-CHECKED-OK 0)
2425   (SETQ L2MAP-SA (+ RAM2O (LSH LEVEL-2-BLOCK-NUMBER 5)))
2426   (DO ADR-IN-BLOCK 0 (1+ ADR-IN-BLOCK) (= ADR-IN-BLOCK 32.)
2427       (SETQ L2M (CC-REGISTER-EXAMINE (+ ADR-IN-BLOCK L2MAP-SA)))
2428       (COND ((>= (LOGLDB %%PHT2-MAP-STATUS-CODE L2M)    ;IF LEVEL 2 MAP SET UP ...
2429                  %PHT-MAP-STATUS-READ-ONLY)
2430              (SETQ PHT-ADR (QF-PAGE-HASH-TABLE-LOOKUP
2431                             (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
2432              (COND ((< PHT-ADR 0)
2433                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS)
2434                            (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS
2435                                         VIR-ADR 'NOT-FOUND-IN-PHT))
2436                            (PRINT (LIST 'MAP-VALUE L2M
2437                                         'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
2438                                                                  5)
2439                                                             ADR-IN-BLOCK))))))
2440                    ((NOT (= (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER L2M)
2441                             (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER
2442                                     (SETQ PHT-VALUE (PHYS-MEM-READ (1+ PHT-ADR))))))
2443                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'DIFFERS-FROM-PHT))
2444                     (PRINT (LIST 'MAP-VALUE L2M
2445                                  'PHT-VALUE PHT-VALUE
2446                                  'PHT-ADR PHT-ADR
2447                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
2448                                                           5)
2449                                                      ADR-IN-BLOCK))))
2450                    ((NOT (= (LOGLDB %%PHT2-META-BITS L2M)
2451                             (LOGLDB %%PHT2-META-BITS PHT-VALUE)))
2452                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'META-BITS-DIFFER))
2453                     (PRINT (LIST 'MAP-VALUE L2M
2454                                  'PHT-VALUE PHT-VALUE
2455                                  'PHT-ADR PHT-ADR
2456                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
2457                                                           5)
2458                                                      ADR-IN-BLOCK))))
2459                    (T (SETQ NUM-CHECKED-OK (1+ NUM-CHECKED-OK)))))))
2460   (RETURN NUM-CHECKED-OK)))
2461
2462(DEFPROP MEMSTAT CC-DESCRIBE-MEMORY CC-COLON-CMD)
2463
2464;:MEMSTAT TELL ALL ABOUT ALL PAGES THAT ARE SWAPPED IN
2465(DEFUN CC-DESCRIBE-MEMORY (TEM)
2466  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
2467  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
2468  ; META BITS, MAP STATUS, ACCESS CODE
2469  (DO L (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CC-DESCRIBE-MEMORY-COPY-OUT-PHT) NIL)
2470      (CDR L) (NULL L)                                  ;PROCESS EACH CONTIG AREA
2471    (DO LL (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (NREVERSE (CAR L)) NIL)
2472           (CDR LL) (NULL LL)
2473      (PRINT (CAAAR LL))                                ;FIRST VIRTUAL ADDRESS
2474      (TYO 11)
2475      (COND ((< (CADAAR LL) (LENGTH AREA-LIST))         ;PRINT AREA NAME, TRYING TO BE
2476             (PRIN1-THEN-SPACE (NTH (CADAAR LL) AREA-LIST)))    ;QUICK ABOUT IT
2477            (T (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ (CADAAR LL)
2478                                                  (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))))
2479               (TYO 40)))
2480      (PRIN1 (// (- (CAAAR LL)
2481                     (SETQ TEM (QF-POINTER              ;AREA NUMBER TO AREA ORIGIN
2482                                 (QF-MEM-READ (+ (CADAAR LL)
2483                                                 (QF-INITIAL-AREA-ORIGIN 'AREA-ORIGIN))))))
2484                  PAGE-SIZE))                           ;FIRST RELATIVE PAGE NUM
2485      (COND ((> (LENGTH (CAR LL)) 1)                    ;IF MULTI PAGES CONTIG
2486             (PRINC '-)
2487             (PRIN1 (// (- (CAAR (LAST (CAR LL))) TEM) PAGE-SIZE))))
2488      (PRINC '|  -->  |)                                ;MAPS ONTO
2489      (CC-DESCRIBE-MEMORY-PRINT-ATTRIB (CAAR LL))))     ;SAY WHAT IT MAPS ONTO
2490  (TERPRI)
2491  NIL)
2492
2493(DEFUN CC-DESCRIBE-MEMORY-PRINT-ATTRIB (X)
2494  (PRIN1-THEN-SPACE (CADDDR X))                         ;PHYSICAL ADDRESS
2495  (AND (CADDR X) (PRIN1-THEN-SPACE (CADDR X)))          ;SWAP STATUS IF ABNORMAL
2496  (PRIN1-THEN-SPACE (CADR (CDDDDR X)))                  ;MAP STATUS
2497  (AND (CADDR (CDDDDR X))
2498       (PRIN1-THEN-SPACE (CADDR (CDDDDR X))))           ;ACCESS IF ANY
2499  (OR (= 0 (CAR (CDDDDR X)))
2500      (PRIN1 'META-BITS=)
2501      (PRIN1 (CAR (CDDDDR X)))))                        ;META BITS IF NON-ZERO
2502
2503  ;GET LIST OF REVERSE LISTS (FOR CONTIG AREAS) OF LISTS
2504  ;EACH 3RD LEVEL LIST IS VIRTUAL ADDR, AREA NUMBER, SWAP STATUS, PHYS ADDR,
2505  ; META BITS, MAP STATUS, ACCESS CODE
2506;CONVERT ONE LIST OF PAGES INTO N, FOR THE CONTIGUOUS SUBSETS
2507(DEFUN CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (LL PREV-CONTIG)
2508  (COND ((NULL PREV-CONTIG)
2509         (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL))))
2510        ((NULL LL)
2511         (LIST (NREVERSE PREV-CONTIG)))
2512        ((AND (= (- (CADDDR (CAR LL)) PAGE-SIZE)
2513                 (CADDDR (CAR PREV-CONTIG)))    ;PHYS ADDRS AGREE
2514              (EQ (CADDR (CAR LL)) (CADDR (CAR PREV-CONTIG)))   ;SWAP STATUS AGREE
2515              (EQUAL (CDDDDR (CAR LL)) (CDDDDR (CAR PREV-CONTIG)))) ;OTHER STUFF AGREES
2516         (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (CONS (CAR LL) PREV-CONTIG)))
2517        (T                                                      ;START NEW CONTIG FROB
2518         (CONS (NREVERSE PREV-CONTIG)
2519               (CC-DESCRIBE-MEMORY-CONTIG-SPLITUP (CDR LL) (LIST (CAR LL)))))))
2520
2521(DEFUN CC-DESCRIBE-MEMORY-COLLECT-CONTIG (SORTED-PHT-LIST PREVIOUS-CONTIG-LIST)
2522  (COND ((NULL SORTED-PHT-LIST)
2523         (AND PREVIOUS-CONTIG-LIST (LIST PREVIOUS-CONTIG-LIST)))
2524        ((NULL PREVIOUS-CONTIG-LIST)
2525         (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
2526                                            (LIST (CAR SORTED-PHT-LIST))))
2527        ((AND (= (CADAR SORTED-PHT-LIST) (CADAR PREVIOUS-CONTIG-LIST)) ;SAME AREA
2528              (= (CAAR SORTED-PHT-LIST)
2529                 (+ PAGE-SIZE (CAAR PREVIOUS-CONTIG-LIST)))) ;NEXT VIR ADR
2530         (CC-DESCRIBE-MEMORY-COLLECT-CONTIG (CDR SORTED-PHT-LIST)
2531                                            (CONS (CAR SORTED-PHT-LIST) PREVIOUS-CONTIG-LIST)))
2532        (T
2533         (CONS PREVIOUS-CONTIG-LIST
2534               (CC-DESCRIBE-MEMORY-COLLECT-CONTIG SORTED-PHT-LIST NIL)))))
2535
2536(DECLARE (SPECIAL %PHT-DUMMY-VIRTUAL-ADDRESS %%PHT1-VIRTUAL-PAGE-NUMBER))
2537
2538(DEFUN CC-DESCRIBE-MEMORY-COPY-OUT-PHT NIL
2539  (SORTCAR
2540    (DO ((PHTP (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-PNTR))) (+ PHTP 2))
2541         (COUNT (// (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) 2)
2542                (1- COUNT))
2543         (PHT1)
2544         (PHT2)
2545         (VIRAD)
2546         (LST NIL))
2547        ((= 0 COUNT) LST)
2548      (DECLARE (FIXNUM PHTP COUNT PHT1 PHT2 VIRAD))
2549      (COND ((AND (NOT (= 0 (LOGAND 100 (SETQ PHT1 (PHYS-MEM-READ PHTP)))))
2550                  (NOT (= %PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER PHT1))))
2551             (SETQ LST (CONS (LIST (SETQ VIRAD (* PAGE-SIZE             ;VIRTUAL ADDRESS
2552                                                  (LOGLDB %%PHT1-VIRTUAL-PAGE-NUMBER PHT1)))
2553
2554                                   (QF-AREA-NUMBER-OF-POINTER VIRAD)    ;AREA NUMBER
2555                                   (NTH (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1)
2556                                        '(SWAP-STATUS-ZERO?
2557                                          NIL FLUSHABLE SWAP-STATUS-PDL-BUFFER
2558                                          AGE-TRAP WIRED SWAP-STATUS-6?
2559                                          SWAP-STATUS-7?))
2560                                   (* PAGE-SIZE         ;PHYSICAL ADDRESS
2561                                      (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER
2562                                              (SETQ PHT2 (PHYS-MEM-READ (1+ PHTP)))))
2563                                   (LOGLDB %%PHT2-META-BITS PHT2)
2564                                   (NTH (LOGLDB %%PHT2-MAP-STATUS-CODE PHT2)
2565                                        '(LEVEL-1-MAP-NOT-VALID?
2566                                          LEVEL-2-MAP-NOT-VALID?
2567                                          READ-ONLY READ-WRITE-FIRST READ-WRITE
2568                                          MAP-STATUS-PDL-BUFFER
2569                                          MAP-STATUS-6? MAP-STATUS-7?))
2570                                   (NTH (LOGLDB %%PHT2-MAP-ACCESS-CODE PHT2)
2571                                        '(NIL NIL R-ACCESS R-W-ACCESS)))
2572                             LST)))))
2573    (FUNCTION <)))
2574
2575(DEFPROP RELPC CC-RELPC CC-COLON-CMD)
2576
2577(DEFUN CC-RELPC (IGNORE)
2578  (PROG (M-AP LC)
2579        (SETQ M-AP (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2580                                           RAPBO)))
2581        (CC-Q-PRINT-TOPLEV M-AP)
2582        (COND ((= (LOGLDB %%Q-DATA-TYPE M-AP)
2583                  DTP-FEF-POINTER)
2584               (SETQ LC
2585                     (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
2586               (TYO 40)
2587               (PRIN1 (- (QF-POINTER LC)
2588                         (* 2 (QF-POINTER M-AP)))) ))))
2589
2590(DECLARE (SPECIAL %%LP-EXS-EXIT-PC %%LP-CLS-DELTA-TO-ACTIVE-BLOCK
2591                  %%LP-CLS-DELTA-TO-OPEN-BLOCK
2592                  %%LP-ENS-NUM-ARGS-SUPPLIED))
2593
2594(DEFUN (TRACE CC-COLON-CMD) (COUNT)
2595     (CC-TRACE-COMMAND COUNT T))
2596
2597(DEFUN (TRACEN CC-COLON-CMD) (COUNT)
2598     (CC-TRACE-COMMAND COUNT NIL))
2599
2600(DEFUN CC-TRACE-COMMAND (COUNT PRINT-ARGS-P)
2601    (TERPRI)
2602    (CC-TRACE-THE-STACK (COND ((NULL COUNT)
2603                               (SETQ COUNT 7777777)
2604                               (COND ((AND CC-LAST-VALUE-TYPED
2605                                           (= (QF-DATA-TYPE CC-LAST-VALUE-TYPED)
2606                                              DTP-STACK-GROUP))
2607                                      CC-LAST-VALUE-TYPED)
2608                                     (T T)))
2609                              ((MINUSP COUNT)
2610                               (SETQ COUNT (- COUNT))
2611                               NIL)
2612                              (T T))
2613                        PRINT-ARGS-P
2614                        COUNT))
2615
2616;; First argument, MODE, is NIL to use the current stack group from the pdl buffer,
2617;; T for the current stack group from memory, or a stack group to trace.
2618;; Second argument, PRINT-ARGS-P, is T if you want the arguments to be printed
2619;; for each frame.
2620(DEFUN CC-TRACE-THE-STACK (MODE PRINT-ARGS-P COUNT)
2621    (PROG (M-AP CALL-WORD EXIT-WORD ENTRY-WORD FUNCTION-WORD FRAME-TYPE TIMES)
2622          (SETQ TIMES 0)
2623          (SETQ M-AP
2624                (QF-POINTER
2625                 (COND ((NULL MODE)
2626                        (+ RAPBO (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)))
2627                       ((EQ MODE T)
2628                        (+ (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER
2629                                        'A-PDL-BUFFER-VIRTUAL-ADDRESS))
2630                           (LOGAND 1777 (- (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2631                                           (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER
2632                                                        'A-PDL-BUFFER-HEAD))))))
2633                       (T (SETQ MODE (QF-MAKE-Q MODE DTP-ARRAY-POINTER))
2634                          (LET ((RP (QF-ARRAY-LEADER MODE SG-REGULAR-PDL)))
2635                            (+ RP
2636                               (QF-ARRAY-LEADER MODE SG-AP)
2637                               1
2638                               (LOGLDB %%ARRAY-LONG-LENGTH-FLAG (CC-MEM-READ RP))))))))
2639        LOOP
2640          (OR #M (ZEROP (LISTEN)) #Q (NOT (KBD-TYI-NO-HANG)) (RETURN NIL))
2641          (COND ((NULL MODE)
2642                 (SETQ CALL-WORD (CC-REGISTER-EXAMINE (- M-AP 3)))
2643                 (SETQ EXIT-WORD (CC-REGISTER-EXAMINE (- M-AP 2)))
2644                 (SETQ ENTRY-WORD (CC-REGISTER-EXAMINE (- M-AP 1)))
2645                 (SETQ FUNCTION-WORD (CC-REGISTER-EXAMINE M-AP)))
2646                (T
2647                 (SETQ CALL-WORD (CC-MEM-READ (- M-AP 3)))
2648                 (SETQ EXIT-WORD (CC-MEM-READ (- M-AP 2)))
2649                 (SETQ ENTRY-WORD (CC-MEM-READ (- M-AP 1)))
2650                 (SETQ FUNCTION-WORD (CC-MEM-READ M-AP))))
2651          (SETQ FRAME-TYPE (NTH (LOGLDB %%Q-DATA-TYPE FUNCTION-WORD) Q-DATA-TYPES))
2652
2653          ;;; Print out info about this frame.
2654          (PRIN1-THEN-SPACE M-AP)
2655          (CC-Q-PRINT-TOPLEV FUNCTION-WORD)
2656          (COND ((AND (EQ FRAME-TYPE 'DTP-FEF-POINTER)
2657                      (NOT (AND (ZEROP TIMES)
2658                                (MEMQ MODE '(T NIL)))))
2659                 (PRINC '/[)
2660                 (PRIN1 (LOGLDB %%LP-EXS-EXIT-PC EXIT-WORD))
2661                 (PRINC '/])))
2662          (COND (PRINT-ARGS-P
2663                 (DO ((ADR (1+ M-AP) (1+ ADR))
2664                      (CC-SEXP-PRINLEVEL 2)
2665                      (CC-SEXP-PRINLENGTH 3)
2666                      (CNT (LOGLDB %%LP-ENS-NUM-ARGS-SUPPLIED ENTRY-WORD) (1- CNT)))
2667                     ((ZEROP CNT))
2668                   (DECLARE (FIXNUM ADR CNT))
2669                   (PRINC '| |)
2670                   (CC-Q-PRINT-TOPLEV (COND ((NULL MODE) (CC-REGISTER-EXAMINE ADR))
2671                                            (T (CC-MEM-READ ADR)))))))
2672          (TERPRI)
2673          (OR (< (SETQ TIMES (1+ TIMES)) COUNT)
2674              (RETURN NIL))
2675          (LET ((DELTA (LOGLDB %%LP-CLS-DELTA-TO-ACTIVE-BLOCK CALL-WORD)))
2676            (COND ((ZEROP DELTA) (RETURN NIL))
2677                  (T (SETQ M-AP (- M-AP DELTA))
2678                     (GO LOOP))))
2679          ))
2680
2681(DECLARE (SPECIAL %%FEFH-PC %FEFHI-IPC %FEFHI-STORAGE-LENGTH))
2682
2683(DECLARE (NOTYPE (CC-CODE-INSN FIXNUM FIXNUM FIXNUM)))
2684
2685(DEFUN (CODE CC-COLON-CMD) (ARG)
2686   (TERPRI)
2687   (LET ((PC (COND (CC-OPEN-REGISTER 0)
2688                   (T (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))))
2689         (FEF (COND (CC-OPEN-REGISTER (CC-REGISTER-EXAMINE CC-OPEN-REGISTER))
2690                    (T (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
2691                                               RAPBO))))))
2692     (DECLARE (FIXNUM PC FEF))
2693     (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER))
2694            (PRINC '|The current function is not a FEF.|) (TERPRI))
2695           (T (SETQ FEF (QF-POINTER FEF))
2696              (PRINC (COND (CC-OPEN-REGISTER '|FEF is |)
2697                           (T '|Current FEF is |)))
2698              (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ %FEFHI-FCTN-NAME FEF)))
2699              (TERPRI)
2700              (LET ((RELPC (- PC (* 2 FEF))))
2701                (DECLARE (FIXNUM RELPC))
2702                (COND ((AND (NULL CC-OPEN-REGISTER) (OR (< RELPC 10) (> RELPC 10000)))
2703                       (PRINC '|The PC does not seem to be pointer to the running FEF.|)
2704                       (TERPRI))
2705                      (T (CC-DISASSEMBLE-FEF FEF (COND ((OR CC-OPEN-REGISTER (EQ ARG 1)) NIL)
2706                                                       (T RELPC))))))))))
2707
2708(DEFUN (DISASSEMBLE-FEF CC-COLON-CMD) (ARG)
2709  ARG
2710  (AND CC-LAST-VALUE-TYPED
2711       (= (QF-DATA-TYPE CC-LAST-VALUE-TYPED) DTP-FEF-POINTER)
2712       (PROGN (PRINC '|Type center PC or NIL|)
2713              (CC-DISASSEMBLE-FEF CC-LAST-VALUE-TYPED (READ)))))
2714
2715(DECLARE (NOTYPE (CC-DISASSEMBLE-FEF FIXNUM NOTYPE)))
2716
2717(DEFUN CC-DISASSEMBLE-FEF (FEF CENTER-PC)
2718  (LET ((FROM-RELPC 0) (TO-RELPC 0)
2719        (INIT-RELPC (LOGLDB %%FEFH-PC
2720                            (CC-MEM-READ (+ FEF %FEFHI-IPC))))
2721        (LIM-RELPC (* 2 (LOGLDB %%Q-POINTER
2722                                (CC-MEM-READ
2723                                  (+ FEF %FEFHI-STORAGE-LENGTH))))))
2724    (DECLARE (FIXNUM FROM-RELPC TO-RELPC INIT-RELPC LIM-RELPC))
2725    (SETQ FROM-RELPC
2726          (LOGAND -2 (COND ((NULL CENTER-PC) INIT-RELPC)
2727                           (T (MAX (- 10 CENTER-PC) INIT-RELPC)))))
2728    (SETQ TO-RELPC
2729          (COND ((NULL CENTER-PC) LIM-RELPC)
2730                (T (MIN (+ 3 CENTER-PC) LIM-RELPC))))
2731    (COND ((NULL CENTER-PC) (SETQ CENTER-PC -1)))
2732    (DO ((I FROM-RELPC (+ 2 I)))
2733        ((NOT (< I TO-RELPC)))
2734      (DECLARE (FIXNUM I))
2735      (LET ((WORD (QF-MEM-READ (+ (LSH I -1) FEF))))
2736        (DECLARE (FIXNUM WORD))
2737        (CC-CODE-INSN (LOGLDB 0020 WORD) I CENTER-PC)
2738        (CC-CODE-INSN (LOGLDB 2020 WORD) (1+ I) CENTER-PC)))))
2739
2740(DEFUN CC-CODE-INSN (INST ADDR CENTER-PC)
2741    (PRINC (COND ((= CENTER-PC ADDR) '|=> |)
2742                 (T '|   |)))
2743    (PRINC ADDR) (PRINC '| |)
2744    (CC-TYPE-OUT INST CC-INST-DESC T NIL)
2745    (TERPRI)
2746    NIL)
2747
2748(DEFUN (PF CC-COLON-CMD) (IGNORE)
2749  (COND ((NULL CC-OPEN-REGISTER)
2750         (PRINC '|NO REGISTER OPEN (SHOULD BE AN LP-FEF WORD OF A FRAME)|))
2751        (T
2752    (LET ((CALL-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 3)))
2753          (EXIT-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 2)))
2754          (ENTRY-WORD (CC-REGISTER-EXAMINE (- CC-OPEN-REGISTER 1)))
2755          (FUNCTION-WORD (CC-REGISTER-EXAMINE CC-OPEN-REGISTER)))
2756       (TERPRI) (CC-TYPE-OUT FUNCTION-WORD 'CC-SEXP-DESC T NIL)
2757       (TERPRI) (CC-TYPE-OUT CALL-WORD 'CALL-WORD-DESC 'ALL NIL)
2758       (TERPRI) (CC-TYPE-OUT EXIT-WORD 'EXIT-WORD-DESC 'ALL NIL)
2759       (TERPRI) (CC-TYPE-OUT ENTRY-WORD 'ENTRY-WORD-DESC 'ALL NIL)
2760     (COND ((NOT (ZEROP (LOGLDB %%LP-CLS-ADI-PRESENT CALL-WORD)))
2761            (DO ((ADR (- CC-OPEN-REGISTER 4) (- ADR 2))
2762                 (W1)(W2))
2763                (NIL)
2764              (DECLARE (FIXNUM ADR W1 W2))
2765              (SETQ W1 (CC-REGISTER-EXAMINE ADR)
2766                    W2 (CC-REGISTER-EXAMINE (- ADR 1)))
2767              (TERPRI)
2768              (CC-TYPE-OUT W1 'ADI-W1-DESC 'ALL NIL)
2769              (TERPRI)
2770              (CC-TYPE-OUT W2 'ADI-W2-DESC 'ALL NIL)
2771              (AND (ZEROP (LOGLDB %%Q-FLAG-BIT W2)) (RETURN NIL))))))))
2772  (TERPRI))
2773
2774(SETQ CALL-WORD-DESC '(
2775    (TYPE CALL-WORD)
2776    (SELECT-FIELD DOWNWARD-CLOSURE-PUSHED 2501 (NIL DOWNWARD-CLOSURE-PUSHED))
2777    (SELECT-FIELD ADI-PRESENT 2401 (NIL ADI-PRESENT))
2778    (SELECT-FIELD S-DEST 2004 (D-INDS D-PDL D-NEXT D-LAST D-RETURN T T D-NEXT-LIST D-MICRO))
2779    (TYPE-FIELD DELTA-TO-OPEN-BLOCK 1010 NIL)
2780    (TYPE-FIELD DELTA-TO-ACTIVE-BLOCK 0010 NIL)))
2781
2782(SETQ EXIT-WORD-DESC '(
2783    (TYPE EXIT-WORD)
2784    (SELECT-FIELD MICRO-STACK-SAVED 2101 (NIL MICRO-STACK-SAVED))
2785    (SELECT-FIELD BINDING-BLOCK-PUSHED 2001 (NIL BINDING-BLOCK-PUSHED))
2786    (TYPE-FIELD SAVED-PC 0017 NIL)))
2787
2788(SETQ ENTRY-WORD-DESC '(
2789    (TYPE ENTRY-WORD)
2790    (TYPE-FIELD NUM-ARGS 1006 NIL)
2791    (TYPE-FIELD LOC-BLOCK-ORIGIN 0010 NIL)))
2792
2793(SETQ ADI-W1-DESC '(
2794    (TYPE ADI-W1)
2795    (SELECT-FIELD FLAG-BIT 3501 (NO-FLAG-BIT-ERROR NIL))
2796    (SELECT-FIELD ADI-TYPE 2403 (ERR RETURN-INFO RESTART-PC FEXPR-CALL LEXPR-CALL
2797                                   BIND-STACK-LEVEL T USED-UP-RETURN-INFO))
2798    (SELECT-FIELD STORING-OPT 2103 (ERR BLOCK LIST MAKE-LIST INDIRECT T T T))
2799    (TYPE-FIELD NUM-VALS-EXPECTING 0006 NIL)))
2800
2801(SETQ ADI-W2-DESC '(
2802    (TYPE ADI-W2)
2803    (TYPE-FIELD FLAG-BIT 3501 NIL)
2804    (TYPE-FIELD W2 0030 NIL)))
2805
2806;Search physical memory (ie currently swapped in stuff) for arg.
2807(DEFUN (PHYS-MEM-WORD-SEARCH CC-COLON-CMD) (QUAN)
2808  (DECLARE (FIXNUM ADR TEM))
2809  (DO ((ADR 0 (1+ ADR))
2810       (TEM))
2811      ((OR (= ADR 400000) #Q (KBD-TYI-NO-HANG) #M NIL))   ;SEARCHES 128K  **CROCK**
2812      (COND ((= QUAN (SETQ TEM (PHYS-MEM-READ ADR)))
2813             (FORMAT T '|~%~S/  ~S  | ADR TEM)))))
2814
2815(DECLARE (SPECIAL CONS-FUNC-DEST-INT-CNTRL)) ;CADMAC does not get included in compilation
2816
2817;:INTOFF disables hardware interrupts and sequence breaks
2818(DEFUN (INTOFF CC-COLON-CMD) (IGNORE)
2819  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-INT-CNTRL 0))
2820
2821(DEFUN (DESCRIBE CC-COLON-CMD) (IGNORE)
2822  (AND CC-LAST-VALUE-TYPED
2823       (LET ((DT (QF-DATA-TYPE CC-LAST-VALUE-TYPED)))
2824         (COND ((= DT DTP-STACK-GROUP)
2825                (CC-DESCRIBE-STACK-GROUP CC-LAST-VALUE-TYPED))
2826               ((OR (= DT DTP-CLOSURE)
2827                    (= DT DTP-ENTITY))
2828                (CC-DESCRIBE-CLOSURE CC-LAST-VALUE-TYPED))
2829               ((= DT DTP-FEF-POINTER)
2830                (CC-DESCRIBE-FEF CC-LAST-VALUE-TYPED))))))
2831
2832(IF-FOR-MACLISP
2833(DECLARE (SPECIAL SG-NAME SG-STATE %%SG-ST-IN-SWAPPED-STATE %%SG-ST-FOOTHOLD-EXECUTING
2834                  %%SG-ST-PROCESSING-ERROR %%SG-ST-CURRENT-STATE SG-STATES SG-SAVED-M-FLAGS
2835                  SG-REGULAR-PDL-POINTER SG-SPECIAL-PDL SG-SPECIAL-PDL-POINTER)))
2836
2837(DEFUN CC-DESCRIBE-STACK-GROUP (SG)
2838  (PROG (PNTR)
2839        (SETQ PNTR (QF-POINTER SG))
2840        (FORMAT T "~%Stack group: " )
2841        (CC-Q-PRINT-TOPLEV (CC-MEM-READ (- PNTR 2 SG-NAME)))
2842        (LET ((STATE (CC-MEM-READ (- PNTR 2 SG-STATE))))
2843           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-IN-SWAPPED-STATE STATE)))
2844                  (FORMAT T "~% Variables currently swapped out")))
2845           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-FOOTHOLD-EXECUTING STATE)))
2846                  (FORMAT T "~% Foothold currently executing")))
2847           (COND ((NOT (ZEROP (LOGLDB %%SG-ST-PROCESSING-ERROR STATE)))
2848                  (FORMAT T "~% Currently processing an error")))
2849           (FORMAT T ", State ~S" (NTH (LOGLDB %%SG-ST-CURRENT-STATE STATE) SG-STATES)))
2850        (DO ((L STACK-GROUP-HEAD-LEADER-QS (CDR L))
2851             (A (- PNTR 2) (1- A))
2852             (WD))
2853            ((NULL L))
2854          (FORMAT T "~%~O~10T~A:~30T" A (CAR L))
2855          (SETQ WD (CC-MEM-READ A))
2856          (CC-TYPE-OUT WD CC-Q-DESC NIL NIL)
2857          (TYO #\TAB)
2858          (ERRSET (CC-Q-PRINT-TOPLEV WD)))
2859        (TERPRI)))
2860
2861(DEFUN CC-DESCRIBE-CLOSURE (CLOS)
2862    (FORMAT T "~%CLOSED-FUNCTION ")
2863    (CC-Q-PRINT-TOPLEV (QF-CAR CLOS))
2864    (DO ((L (QF-CDR CLOS) (QF-CDR (QF-CDR L))))
2865        ((CC-Q-NULL L))
2866      (FORMAT T "~%SYM: ")
2867      (CC-Q-PRINT-TOPLEV (1- (QF-SMASH-DATA-TYPE (QF-CAR L) DTP-SYMBOL)))
2868      (FORMAT T " VALUE:")
2869      (CC-Q-PRINT-TOPLEV (QF-CAR (QF-CAR (QF-CDR L))))))
2870
2871(DEFUN CC-P-LDB-OFFSET (PPSS PNTR OFF)
2872  (LOGLDB PPSS (CC-MEM-READ (+ PNTR OFF))))
2873
2874(DEFUN CC-P-CONTENTS-OFFSET (PNTR OFF)
2875       (LOGLDB %%Q-TYPED-POINTER (CC-MEM-READ (+ PNTR OFF))))
2876
2877(DEFUN CC-DESCRIBE-FEF (FEF &AUX HEADER NAME FAST-ARG SV MISC LENGTH DBI)
2878  (SETQ HEADER (CC-P-LDB-OFFSET %%HEADER-REST-FIELD FEF %FEFHI-IPC))
2879  (SETQ LENGTH (CC-P-CONTENTS-OFFSET FEF %FEFHI-STORAGE-LENGTH))
2880  (SETQ NAME (CC-P-CONTENTS-OFFSET FEF %FEFHI-FCTN-NAME))
2881  (SETQ FAST-ARG (CC-P-CONTENTS-OFFSET FEF %FEFHI-FAST-ARG-OPT))
2882  (SETQ SV (CC-P-CONTENTS-OFFSET FEF %FEFHI-SV-BITMAP))
2883  (SETQ MISC (CC-P-CONTENTS-OFFSET FEF %FEFHI-MISC))
2884  (FORMAT T "~%FEF for function ") (CC-Q-PRINT-TOPLEV NAME) (TERPRI)
2885  (FORMAT T "Initial relative PC: ~S halfwords.~%" (LOGLDB %%FEFH-PC HEADER))
2886; -- Print out the fast arg option
2887  (FORMAT T "The Fast Argument Option is ~A"
2888          (IF (ZEROP (LOGLDB %%FEFH-FAST-ARG HEADER))
2889              "not active, but here it is anyway:"
2890              "active:"))
2891  (SI:DESCRIBE-NUMERIC-DESCRIPTOR-WORD FAST-ARG)
2892; -- Randomness.
2893  (FORMAT T "~%The length of the local block is ~S~%"
2894          (LOGLDB %%FEFHI-MS-LOCAL-BLOCK-LENGTH MISC))
2895  (FORMAT T "The total storage length of the FEF is ~S~%"
2896          LENGTH)
2897; -- Special variables
2898  (COND ((ZEROP (LOGLDB %%FEFH-SV-BIND HEADER))
2899         (PRINC "There are no special variables present."))
2900        (T (PRINC "There are special variables, ")
2901           (TERPRI)
2902           (COND ((ZEROP (LOGLDB %%FEFHI-SVM-ACTIVE SV))
2903                  (PRINC "but the S-V bit map is not active. "))
2904                 (T (FORMAT T "and the S-V bit map is active and contains: ~O"
2905                            (LOGLDB %%FEFHI-SVM-BITS SV))))))
2906  (TERPRI)
2907; -- ADL.
2908  (COND ((ZEROP (LOGLDB %%FEFH-NO-ADL HEADER))
2909         (FORMAT T "There is an ADL:  It is ~S long, and starts at ~S"
2910                 (LOGLDB %%FEFHI-MS-BIND-DESC-LENGTH MISC)
2911                           (LDB %%FEFHI-MS-ARG-DESC-ORG MISC))
2912         (CC-DESCRIBE-ADL (CC-GET-MACRO-ARG-DESC-POINTER FEF))
2913         )
2914        (T (PRINC "There is no ADL.")))
2915  (TERPRI)
2916  DBI
2917; (COND ((SETQ DBI (FUNCTION-DEBUGGING-INFO FEF))
2918;        (FORMAT T "Debugging info:~%")
2919;        (DOLIST (ITEM DBI)
2920;                (FORMAT T "  ~S~%" ITEM))))
2921  )
2922   
2923(DEFUN CC-GET-MACRO-ARG-DESC-POINTER (FEF-POINTER &AUX ORIGIN)
2924   (COND ((= 0 (SETQ ORIGIN
2925                     (CC-P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG FEF-POINTER %FEFHI-MISC)))
2926          (CC-MAKE-POINTER DTP-SYMBOL 0))
2927         (T (CC-MAKE-POINTER-OFFSET DTP-LIST FEF-POINTER ORIGIN))))
2928
2929(DEFUN CC-MAKE-POINTER (DT PNTR)
2930       (LOGDPB DT %%Q-DATA-TYPE PNTR))
2931
2932(DEFUN CC-MAKE-POINTER-OFFSET (DT PNTR OFF)
2933       (LOGDPB DT %%Q-DATA-TYPE (+ PNTR OFF)))
2934
2935(DEFUN CC-DESCRIBE-ADL (ADL)
2936  (PROG (OPT-Q INIT-OPTION)
2937    L   (COND ((CC-Q-NULL ADL) (RETURN NIL)))
2938        (SETQ OPT-Q (QF-CAR ADL) ADL (QF-CDR ADL))
2939        (TERPRI)
2940        (COND ((NOT (ZEROP (LOGAND OPT-Q %FEF-NAME-PRESENT)))
2941               (PRINC "NAME ")
2942               (CC-Q-PRINT-TOPLEV (QF-CAR ADL))
2943               (SETQ ADL (QF-CDR ADL))))
2944        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-SPECIALNESS OPT-Q)
2945                               FEF-SPECIALNESS))
2946        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-DES-DT OPT-Q)
2947                               FEF-DES-DT))
2948        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-QUOTE-STATUS OPT-Q)
2949                               FEF-QUOTE-STATUS))
2950        (PRIN1-THEN-SPACE (NTH (LDB %%FEF-ARG-SYNTAX OPT-Q)
2951                               FEF-ARG-SYNTAX))
2952        (PRIN1-THEN-SPACE (SETQ INIT-OPTION (NTH (LDB %%FEF-INIT-OPTION OPT-Q)
2953                                                 FEF-INIT-OPTION)))
2954        (COND ((MEMQ INIT-OPTION '(FEF-INI-PNTR FEF-INI-C-PNTR
2955                                   FEF-INI-OPT-SA FEF-INI-EFF-ADR))
2956               (PRINC "ARG ")
2957               (CC-Q-PRINT-TOPLEV (QF-CAR ADL))
2958               (SETQ ADL (QF-CDR ADL))))
2959        (GO L)
2960))
2961
2962
2963(DEFUN (FLAGS CC-COLON-CMD) (QUAN)
2964  (CC-TYPE-OUT (OR QUAN (CC-SYMBOLIC-EXAMINE-REGISTER 'M-FLAGS)) 'M-FLAGS-DESC 'ALL NIL))
2965
2966(SETQ M-FLAGS-DESC '(
2967    (TYPE M-FLAGS)
2968    (TYPE-FIELD M-QBFFL 0001 NIL)
2969    (SELECT-FIELD CAR-SYMBOL-MODE 0102 (ERROR NIL->NIL NIL ERROR))
2970    (SELECT-FIELD CAR-NUMBER-MODE 0302 (ERROR NIL ERROR ERROR))
2971    (SELECT-FIELD CDR-SYMBOL-MODE 0502 (ERROR NIL->NIL NIL PLIST))
2972    (SELECT-FIELD CDR-NUMBER-MODE 0702 (ERROR NIL ERROR ERROR))
2973    (SELECT-FIELD DONT-SWAP-IN 1101 (NIL DONT-SWAP-IN))
2974    (TYPE-FIELD TRAP-ENABLE 1201 NIL)
2975    (SELECT-FIELD MAR-MODE 1302 (NIL READ WRITE READ-AND-WRITE))
2976    (SELECT-FIELD PGF-WRITE 1501 (NIL PGF-WRITE))
2977    (SELECT-FIELD INTERRUPT 1601 (NIL INTERRUPT))
2978    (SELECT-FIELD SCAVENGE 1701 (NIL SCAVENGE))
2979    (SELECT-FIELD TRANSPORT 2001 (NIL TRANSPORT))
2980    (SELECT-FIELD STACK-GROUP-SWITCH 2101 (NIL STACK-GROUP-SWITCH))
2981    (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK)) ))
2982
2983(declare (special cc-ilong-range cc-ilong-set cc-ilong-list cc-ilong-high-half))
2984
2985(defun ilong-initialize-search ()
2986  (setq cc-ilong-range '(0 30000))
2987  (setq cc-ilong-set nil)
2988  (setq cc-ilong-list nil)
2989  (setq cc-ilong-high-half t))
2990
2991(defun ilong-setup nil
2992  (if cc-ilong-set (ilong-clear))
2993  (setq cc-ilong-list nil)
2994  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
2995    (do ((adr (car cc-ilong-range) (1+ adr))
2996         wd
2997         (ilong (dpb 1 cons-ir-ilong 0)))
2998        ((>= adr last)
2999          t)
3000      (cond ((zerop (logand ilong (setq wd (cc-read-c-mem adr))))
3001             (cc-write-c-mem adr (logior ilong wd)))
3002            (t (push adr cc-ilong-list)))))
3003  (setq cc-ilong-set t))
3004
3005(defun ilong-clear nil
3006  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
3007    (do ((adr (car cc-ilong-range) (1+ adr))
3008         (ilong-mask (logxor -1 (dpb 1 cons-ir-ilong 0))))
3009        ((>= adr last))
3010      (cond ((memq adr cc-ilong-list))
3011            (t (cc-write-c-mem adr (logand ilong-mask (cc-read-c-mem adr)))))))
3012  (setq cc-ilong-set nil))
3013
3014;if last trial won, subdivide interval
3015;if lost,try other half of interval.
3016(defun ilong-trial (win)
3017  (if cc-ilong-set (ilong-clear))
3018  (cond (win (setq cc-ilong-range (list (car cc-ilong-range)
3019                                        (// (cadr cc-ilong-range) 2)))
3020             (setq cc-ilong-high-half nil))
3021        (cc-ilong-high-half
3022         (format t "~%lost on both halves of range ~s ~s"
3023                 (- (car cc-ilong-range) (cadr cc-ilong-range))
3024                 (+ (car cc-ilong-range) (cadr cc-ilong-range)))
3025         (break foo t))
3026        (t   (setq cc-ilong-range (list (+ (car cc-ilong-range) (cadr cc-ilong-range))
3027                                        (cadr cc-ilong-range)))
3028             (setq cc-ilong-high-half t)))
3029  (format t "~% range now ~s" cc-ilong-range)
3030  (ilong-setup))
Note: See TracBrowser for help on using the repository browser.