-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathACODE
1170 lines (1057 loc) · 70.6 KB
/
ACODE
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Mar-2021 11:17:48" {DSK}<home>larry>ilisp>med>sources>ACODE.;6 71741
changes to%: (FNS PRINTCODENT)
previous date%: "12-Mar-2021 09:50:45" {DSK}<home>larry>ilisp>med>sources>ACODE.;4)
(* ; "
Copyright (c) 1982-1988, 1990-1992, 1995, 2017, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT ACODECOMS)
(RPAQQ ACODECOMS
((COMS (* ; "Printing compiled code")
(FNS PRINTCODE PRINTCODENT)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS PCVAR PRINJUMP NEXTBYTE PRINTCODEHEADERDECODE)
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)))
(COMS (* ; "Analyzing compiled code")
(FNS CALLSCCODE RUNION)
(FNS CHANGECCODE CCCSUBFN? \SUBFNDEF CCCSCAN \CODEBLOCKP)
(FNS \MAP-CODE-POINTERS \MAP-CODE-LITERALS)
(BLOCKS (CALLSCCODE CALLSCCODE RUNION)
(CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN))
(* ;; "MACROS/OPTIMIZERS for getting and setting symbol entries in a compiled-code block. These are parameterized to allow for 2-, 3-, and 4-byte symbol representations.")
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS REFMAP)
(MACROS CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2 CODEBASELT3
CODEBASELT4 CODEBASESETA3 CODEBASESETA4)
(OPTIMIZERS CODEBASESETATOM CODEBASEGETATOM CODEBASEGETNAME BYTESPERCODEATOM
BIG-VMEM-HOST)
(FILES (LOADCOMP)
LLGC LLCODE LLBASIC MODARITH RENAMEMACROS))
(ADDVARS (IGNOREFNS)))
(COMS (* ;
"Maintaining ref count consistency in code")
(FNS \COPYCODEBLOCK \COPYFNHEADER \RECLAIMCODEBLOCK))
(COMS (* ; "Low-level break")
(FNS LLBREAK BROKENDEF))
[COMS (* ; "for TELERAID")
(DECLARE%: DONTCOPY (ADDVARS (RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF))
(EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT
CODEBASELT2 CODEBASESETA CODEBASESETA2
PRINTCODEHEADERDECODE]
(COMS (* ;
"reference to opcodes symbolically")
(FNS PRINTOPCODES)
(GLOBALVARS \OPCODES))
(DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(* ; "Printing compiled code")
(DEFINEQ
(PRINTCODE
[LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE)
(* ; "Edited 12-Mar-2021 09:48 by larry")
(* ; "Edited 25-Feb-91 15:46 ")
(* ; "by sybalsky")
(* ;;; "WARNING: this code must run `renamed' for TeleRaid Printcode to work. However, it is pretty tricky to get it to run renamed because some of the constructs run in local space (e.g., the CARs and CADRs of the code list) and many run in remote space (e.g., the bytes of the code).")
(* ;;; "It seems that frequently when modifying any part of PRINTCODE the renamed version stops working, so *BEWARE* and make sure you test any edits by doing a (DORENAME 'R) and checking TeleRaid's CodePrint command, as well as in normal PRINTCODE mode.")
(* ;;; "All the CODEARRAY accesses are equivalent to FNHEADER accesses indirected thru the CCODEP object. The reason it is done this awful crufty way, instead of fetching the code base, is so this works in Interlisp-10 as well. Might want to punt that now.")
(DECLARE (SPECVARS OUTF))
(OR RADIX (SETQ RADIX 16))
(LET
([CODEBASE (COND
(FN.IS.CODEBASE FN)
(T (OR (\GET-COMPILED-CODE-BASE FN)
[AND (LITATOM FN)
(\GET-COMPILED-CODE-BASE (GET FN 'CODE]
(ERROR FN "not compiled code"]
(I4 (NUMFORMATCODE (LIST 'FIX (if (IGREATERP RADIX 15)
then 3
else 4)
RADIX)))
(I6 (NUMFORMATCODE (LIST 'FIX (if (IGREATERP RADIX 15)
then 5
else 6)
RADIX)))
NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS)
(DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6))
(* ; "Used by PRINTCODENT")
(LET ((*PRINT-BASE* RADIX))
(for I from 0 by BYTESPERWORD while (ILESSP I (UNFOLD (fetch
(FNHEADER
OVERHEADWORDS
)
of T)
BYTESPERWORD))
do (PRINTNUM I4 I OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE I)
OUTF)
(PRINTCODEHEADERDECODE CODEBASE I OUTF) (* ; "Interpret header word")
(TERPRI OUTF)))
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
(PRINTCODENT "name table: " (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD)
(UNFOLD NTSIZE BYTESPERWORD))
(SETQ STARTPC (fetch (FNHEADER STARTPC) of CODEBASE))
(COND
((GREATERP [SETQ NTSIZE (IDIFFERENCE (COND
((fetch (FNHEADER NATIVE)
CODEBASE)
(* ;; "native code has an extra 4 bytes")
(- STARTPC 4))
(T STARTPC))
(SETQ TEMP (IPLUS (UNFOLD (fetch (FNHEADER OVERHEADWORDS)
of T)
BYTESPERWORD)
(COND
((EQ NTSIZE 0)
(* ;
"No nametable, but there's a quad of zeros there anyway")
BYTESPERQUAD)
(T (UNFOLD NTSIZE (ITIMES 2 BYTESPERWORD]
BYTESPERCELL)
(PRINTCODENT "Local args: " TEMP (FOLDLO NTSIZE 2)))
((EQ NTSIZE BYTESPERCELL) (* ; "Debugging info")
(printout OUTF T "Info: " .P2 (\GETBASEPTR CODEBASE (FOLDLO TEMP BYTESPERWORD))
T)))
(printout OUTF T "----" T)
(PROG ((CODELOC STARTPC)
(LEVEL (AND LVFLG 0))
B B1 B2 B3 B4 B5 FN LEN LEVADJ STK)
[ALLOCAL (COND
(LEVEL (SETUPHASHARRAY '\PRINTCODE.LEVEL)
(SETUPHASHARRAY '\PRINTCODE.STKSTATE)
(CLRHASH \PRINTCODE.LEVEL)
(CLRHASH \PRINTCODE.STKSTATE]
LP (COND
((AND PC (IGEQ CODELOC PC)) (* ;
"Caller asked to highlight this spot")
(COND
((NOT (IEQP CODELOC PC))
(PRINTOUT OUTF "(PC ")
(PRINTNUM I4 PC OUTF)
(PRINTOUT OUTF " not found)")))
(printout OUTF "------------------------------" T)
(SETQ PC)))
(COND
((OR (NULL FIRSTBYTE)
(IGEQ CODELOC FIRSTBYTE))
(PRINTNUM I4 CODELOC OUTF)
(PRIN1 ": " OUTF)
[COND
(LVFLG (SETQ TEMP (GETHASH CODELOC \PRINTCODE.LEVEL))
[COND
[LEVEL (COND
([AND TEMP (OR (NEQ LEVEL TEMP)
(NOT (EQUAL STK (GETHASH CODELOC
\PRINTCODE.STKSTATE]
(PRIN1 "*" OUTF]
(T (SETQ LEVEL TEMP)
(SETQ STK (GETHASH CODELOC \PRINTCODE.STKSTATE]
(COND
(LEVEL (TAB 7 NIL OUTF)
(PRINTNUM I4 LEVEL OUTF]
(TAB 12 NIL OUTF))
(T (* ;
"Don't print code, but quietly process LEVEL etc")
(SETQ TAG (\FINDOP (NEXTBYTE)))
(SELECTQ (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG)))
(-X- (TERPRI OUTF)
(RETURN))
(BIND [ALLOCAL (COND
(LEVEL (push STK (SETQ LEVEL
(ADD1 (IDIFFERENCE LEVEL
(LOGAND (CODEBASELT
CODEBASE
CODELOC)
15])
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT
CODEBASE
(ADD1 CODELOC])
(MISCN [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT CODEBASE
(IPLUS 2 CODELOC])
NIL)
[COND
([AND LEVEL (ALLOCAL (SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP LEVADJ)
(SETQ LEVADJ (CAR LEVADJ]
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 (CODEBASELT CODEBASE CODELOC))))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (CODEBASELT CODEBASE CODELOC))))
((JUMP UNWIND)
(SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(ALLOCAL (add CODELOC (fetch OPNARGS of TAG)))
(GO LP)))
[SETQ LEN (LOCAL (fetch OPNARGS of (SETQ TAG (\FINDOP (SETQ B (NEXTBYTE]
(PRINTNUM I4 B OUTF)
(COND
((IGREATERP LEN 0)
(PRINTNUM I4 (SETQ B1 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 1)
(PRINTNUM I4 (SETQ B2 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 2)
(PRINTNUM I4 (SETQ B3 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 3)
(PRINTNUM I4 (SETQ B4 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 4)
(PRINTNUM I4 (SETQ B5 (NEXTBYTE))
OUTF)))
[ALLOCAL (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG))
(SETQ OP# (fetch OP# of TAG))
(SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP OP#)
(SETQ OP# (CAR OP#]
[SELECTQ [SETQ TAG (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG]
(-X- (TERPRI OUTF)
(RETURN))
(IVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
IVARS
'ivar))
(PVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
PVARS
'pvar))
(FVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
FVARS
'fvar))
(JUMP (PRINJUMP (IPLUS (IDIFFERENCE B OP#)
2)))
(SIC (printout OUTF 40 .P2 B1))
(SNIC (printout OUTF 40 .P2 (IDIFFERENCE B1 256)))
(SICX (printout OUTF 40 .P2 (IPLUS (LLSH B1 8)
B2)))
(JUMPX (PRINJUMP (COND
((IGEQ B1 128)
(IDIFFERENCE B1 256))
(T B1))))
(FN
(* ;; "it's a function. Print the name.")
(NEW-SYMBOL-CODE (SETQ B (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)
8)
B4))
(SETQ B (IPLUS (LLSH B1 8)
B2)))
(printout OUTF 40 .P2 (\INDEXATOMDEF B)))
(BIND (TAB 40 NIL OUTF)
[ALLOCAL (PROG ((NNILS (LRSH B1 4))
(NVALS (LOGAND B1 15)))
(for I from (ADD1 (IDIFFERENCE B2 (IPLUS NNILS NVALS)))
to (IDIFFERENCE B2 NNILS) do (SPACES 1 OUTF)
(PCVAR I PVARS
'pvar))
(PRIN1 '; OUTF)
(for I from (ADD1 (IDIFFERENCE B2 NNILS)) to B2
do (SPACES 1 OUTF)
(PCVAR I PVARS 'pvar))
(COND
(LEVEL (push STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL
NVALS])
(JUMPXX [PRINJUMP (IPLUS (LLSH B1 8)
B2
(COND
((IGREATERP B1 127)
-65536)
(T 0])
(ATOM [printout OUTF 40 .P2
(\INDEXATOMPNAME (NEW-SYMBOL-CODE
(IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)
8)
B4)
(IPLUS (LLSH B1 8)
B2])
(GCONST [printout OUTF 40 .P2 (1ST (\VAG2 (IPLUS (LLSH B1 8)
B2)
(IPLUS (LLSH B3 8)
B4])
(FNX [printout OUTF "(" B1 ")" 40 .P2
(\INDEXATOMDEF (NEW-SYMBOL-CODE
(IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8)
B3)
8)
B4)
8)
B5)
(IPLUS (LLSH B2 8)
B3])
(TYPEP (printout OUTF "(" .P2 (OR (\TYPENAMEFROMNUMBER B1)
'?)
")"))
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [ALLOCAL (printout OUTF 40 (for X in \INITSUBRS
when (EQ B1 (CADR X))
do (RETURN (CAR X))
finally (RETURN "?"]
[AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2])
(MISCN [ALLOCAL (printout OUTF 40 (for X in \USER-SUBR-LIST
when (EQ B1 (CADR X))
do (RETURN (CAR X)) finally (RETURN
"?"]
[AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2])
(ALLOCAL (COND
((LISTP TAG)
(printout OUTF 40 (CAR (NTH TAG (ADD1 B1]
(TERPRI OUTF)
[COND
((AND LEVEL LEVADJ)
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 B1)))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1)))
((JUMP UNWIND)
(SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(GO LP])
(PRINTCODENT
[LAMBDA (STR START1 START2)
(DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF))
(* ; "Edited 12-Mar-2021 11:17 by larry")
(* ;; "Prints the name table identified with title STR that starts with names at START1 and codes at START2")
(LET (NAME TAG)
(COND
((ILESSP START1 (SETQ START2 (IPLUS START2 START1)))
(printout OUTF STR T)
(for NT1 from START1 by (BYTESPERNAMEENTRY) while (ILESSP NT1 START2)
as NT2 from START2 by (BYTESPERNTOFFSETENTRY)
do (PRINTNUM I4 NT1 OUTF)
(PRIN1 ": " OUTF)
(for I from 0 to (CONSTANT (SUB1 (BYTESPERNAMEENTRY)))
do (PRINTNUM I4 (CODEBASELT CODEBASE (IPLUS NT1 I))
OUTF))
(SPACES 2 OUTF)
(PRINTNUM I4 NT2 OUTF)
(PRIN1 ": " OUTF)
(COND
((SETQ NAME (\INDEXATOMVAL (CODEBASEGETNAME CODEBASE NT1)))
(SETQ TAG (GETNTOFFSET CODEBASE NT2))
(printout OUTF .SP 1 (SELECTC (NTSLOT-VARTYPE (GETNTOFFSETENTRY CODEBASE
NT2))
(IVARCODE (ALLOCAL (push IVARS
(LIST TAG NAME)))
'IVAR)
(PVARCODE (ALLOCAL (push PVARS
(LIST TAG NAME)))
'PVAR)
(PROGN (ALLOCAL (push FVARS (LIST TAG NAME)))
'FVAR))
" " TAG ": " .P2 NAME)))
(TERPRI OUTF])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS PCVAR MACRO [(IND LST NAME) (* lmm "11-AUG-81 22:27")
(ALLOCAL (PROG NIL
(PRIN2 [CADR (OR (ASSOC IND LST)
(RETURN (printout OUTF "[" NAME IND
"]"]
OUTF])
(PUTPROPS PRINJUMP MACRO [LAMBDA (N)
(PRIN1 "->" OUTF)
(PRINTNUM I4 [SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN]
OUTF)
(COND
(LEVEL (PUTHASH N (SELECTQ LEVADJ
((NCJUMP JUMP)
LEVEL)
(SUB1 LEVEL))
\PRINTCODE.LEVEL)
(PUTHASH N STK \PRINTCODE.STKSTATE])
(PUTPROPS NEXTBYTE MACRO [NIL (CODEBASELT CODEBASE (PROG1 CODELOC (add CODELOC 1])
(PUTPROPS PRINTCODEHEADERDECODE DMACRO
(DEFMACRO (CODEBASE INDEX OUTF) (LET
(INDICES I THERE)
[for NAME in (CDR (RECORDFIELDNAMES 'FNHEADER T))
when (AND NAME (CL:SYMBOLP NAME))
do
[SETQ I (EVAL `(INDEXF (fetch (FNHEADER
,NAME]
(COND
((EQ NAME '%#FRAMENAME)
(add I 1)))
(COND
((SETQ THERE (ASSOC I INDICES))
(push (CDR THERE)
NAME))
(T (push INDICES (LIST I NAME]
`(SELECTQ ,INDEX
(\,@ [for PAIR in INDICES
collect
(CONS
(UNFOLD (CAR PAIR)
BYTESPERWORD)
(COND
[(CDDR PAIR)
(for NAME in (CDR PAIR)
collect
(SELECTQ NAME
((NATIVE CLOSUREP)
`(AND
(fetch
(FNHEADER ,NAME)
of ,CODEBASE)
(PRIN1 ,(CONCAT "[" NAME
"]")
,OUTF)))
`(printout
,OUTF
,(CONCAT " "
(L-CASE (MKSTRING
NAME))
": ")
(fetch (FNHEADER
,NAME)
of ,CODEBASE]
[(EQ (CADR PAIR)
'%#FRAMENAME)
`((printout ,OUTF " frame name: " .P2
(1ST (fetch (FNHEADER
%#FRAMENAME)
of ,CODEBASE]
(T
`((PRIN1
,[CONCAT " "
(L-CASE (MKSTRING
(CADR PAIR]
,OUTF])
NIL))))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)
)
)
(* ; "Analyzing compiled code")
(DEFINEQ
(CALLSCCODE
[LAMBDA (DEF OPTION FNAPPLY) (* DECLARATIONS%: (RECORD RESULT
(LNCALLED CALLED BOUND USEDFREE
GLOBALS)))
(* ;
"Edited 1-Dec-92 00:51 by sybalsky:mv:envos")
(* ;;;
"Analyze DEF for function calls and variable references. Action depends on OPTION as follows:")
(* ;;; "OPTION = NIL means return value of CALLSCCODE as described in IRM;")
(* ;;; "OPTION = T means return list of free variable references;")
(* ;;; "OPTION = APPLY, FNAPPLY, or VARAPPLY means call FNAPPLY on various references and return nothing. FNAPPLY takes two arguments: a symbol and a keyword indicating the type of reference, one of BOUND, USEDFREE, GLOBALS, or CALLED. If OPTION is FNAPPLY, only function references are noticed; if VARAPPLY, only variable bindings and references; otherwise all.")
(* ;;; "For OPTION = NIL or T, CALLSCCODE descends into subfunctions.")
(PROG ((CODEBASE (OR (\GET-COMPILED-CODE-BASE DEF)
(\CODEBLOCKP DEF)
(ERROR DEF "not compiled code")))
(IGNOREFNS IGNOREFNS)
USEDFREE BOUND GLOBALS CALLED LNCALLED NTSIZE NAME TYPE TAG)
(DECLARE (SPECVARS IGNOREFNS))
[COND
((NEQ OPTION 'FNAPPLY) (* ; "Get variables out of name table")
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by (BYTESPERNAMEENTRY) as NT2
from (IPLUS (CONSTANT (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD))
(UNFOLD NTSIZE BYTESPERWORD)) by (BYTESPERNTOFFSETENTRY)
until [NULL (SETQ NAME (\INDEXATOMVAL (GETNAMEENTRY CODEBASE NT1]
do (SETQ TYPE (SELECTQ (NTSLOT-VARTYPE (GETNTOFFSET CODEBASE NT2))
((IVARCODE PVARCODE)
'BOUND)
'USEDFREE)) (* ; "Top two bits of the entry indicate kind of name: 00(\NT.IVARCODE) = IVAR, 10(\NT.PVARCODE) = PVAR, 11 = FVAR")
(SELECTQ OPTION
((VARAPPLY APPLY)
(CL:FUNCALL FNAPPLY NAME TYPE))
(SELECTQ TYPE
(BOUND (pushnew BOUND NAME))
(pushnew USEDFREE NAME]
(PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBASE))
B B1 B2 B3 B4 B5 FN LEN)
LP (SETQ B (NEXTBYTE))
(SETQ B1 (AND [ILESSP 0 (SETQ LEN (fetch OPNARGS of (SETQ TAG (\FINDOP B]
(NEXTBYTE)))
(SETQ B2 (AND (ILESSP 1 LEN)
(NEXTBYTE)))
(SETQ B3 (AND (ILESSP 2 LEN)
(NEXTBYTE)))
(SETQ B4 (AND (ILESSP 3 LEN)
(NEXTBYTE)))
(SETQ B5 (AND (ILESSP 4 LEN)
(NEXTBYTE)))
(SELECTQ (fetch OPCODENAME of TAG)
(-X- (RETURN))
((FN0 FN1 FN2 FN3 FN4)
[COND
[(FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*)
(SETQ NAME (\INDEXATOMDEF
(IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)
8)
B4]
[(FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*)
(SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3]
(T (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B1 8)
B2]
(GO FN))
(FNX [COND
[(FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*)
(SETQ NAME (\INDEXATOMDEF
(IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8)
B3)
8)
B4)
8)
B5]
[(FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*)
(SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH B2 8)
B3)
8)
B4]
(T (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B2 8)
B3]
(GO FN))
(GCONST [SETQ FN (BIG-VMEM-HOST (\VAG2 (IPLUS (LLSH B1 8)
B2)
(IPLUS (LLSH B3 8)
B4))
(\VAG2 B1 (IPLUS (LLSH B2 8)
B3]
(COND
((AND (OR (type? COMPILED-CLOSURE FN)
(\CODEBLOCKP FN))
(NOT (FMEMB FN IGNOREFNS)))
(push IGNOREFNS FN)
(GO COMPILED-CLOSURE))))
((GVAR GVAR_)
[SELECTQ OPTION
(FNAPPLY)
((VARAPPLY APPLY)
(CL:FUNCALL
FNAPPLY
[COND
((FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*)
(\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)
8)
B4)))
((FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*)
(\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)))
(T (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2]
'GLOBALS))
(pushnew GLOBALS
(COND
((FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*)
(\INDEXATOMVAL
(IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)
8)
B4)))
((FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*)
(\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH B1 8)
B2)
8)
B3)))
(T (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2])
NIL)
(GO LP)
FN [SELECTQ OPTION
((FNAPPLY APPLY)
(CL:FUNCALL FNAPPLY NAME 'CALLED))
(VARAPPLY)
(COND
((FMEMB NAME IGNOREFNS) (* ; "Don't show calls to these")
)
((SETQ FN (\SUBFNDEF NAME))
(push IGNOREFNS NAME)
(GO COMPILED-CLOSURE))
((EQ OPTION T) (* ; "Only look at vars")
)
(T (pushnew CALLED NAME]
(GO LP)
COMPILED-CLOSURE
(* ;
"Compiled subfunction, recursively analyze it")
[LET ((RESULT (CALLSCCODE FN OPTION FNAPPLY)))
(AND RESULT (COND
((EQ OPTION T) (* ; "Just got free variables back")
(SETQ USEDFREE (RUNION RESULT USEDFREE)))
(T (SETQ LNCALLED (RUNION (fetch LNCALLED of RESULT)
LNCALLED))
(SETQ BOUND (RUNION (fetch BOUND of RESULT)
BOUND))
(SETQ USEDFREE (RUNION (fetch USEDFREE of RESULT)
USEDFREE))
(SETQ GLOBALS (RUNION (fetch GLOBALS of RESULT)
GLOBALS))
(SETQ CALLED (RUNION (fetch CALLED of RESULT)
CALLED]
(GO LP))
(RETURN (SELECTQ OPTION
((FNAPPLY VARAPPLY APPLY)
NIL)
(T (* ; "All free var references")
(RUNION USEDFREE GLOBALS))
(create RESULT
LNCALLED _ (REVERSE LNCALLED)
CALLED _ (REVERSE CALLED)
BOUND _ (REVERSE BOUND)
USEDFREE _ (REVERSE USEDFREE)
GLOBALS _ (REVERSE GLOBALS])
(RUNION
(LAMBDA (L1 L2) (* bvm%: "14-Mar-86 14:27") (* ;;; "Fast UNION using EQ") (for X in L1 unless (FMEMB X L2) do (push L2 X)) L2)
)
)
(DEFINEQ
(CHANGECCODE
[LAMBDA (NEWREF OLDREF FN) (* ;
"Edited 13-Nov-92 14:13 by sybalsky:mv:envos")
(* ;;; "A reference map is a list (`refmap' E1 ... EN), where each element E has the form (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS). The first element is for the main function, and further elements are for compiler-generated subfunctions. Each LOCS list is a list of byte locations in the code to be fixed up in the indicated way (i.e. VALINDEX, LOLOC, DEFINDEX, and full 24-bit pointer in GCONST format respectively).")
(DECLARE (SPECVARS ALL-CODE-BASES)) (* ;
"ALL-CODE-BASES is list of all code bases examined. See CCCSUBFN? for details.")
(PROG ((SEAL '"refmap")
DEF MAP ALL-CODE-BASES)
(SETQ DEF (OR (\GET-COMPILED-CODE-BASE FN)
(RETURN)))
[COND
[(NEQ (CAR (LISTP OLDREF))
SEAL) (* ;
"Construct a reference map for OLDREF in DEF")
(COND
((EQ (PROG1 OLDREF
(SETQ OLDREF (CONS SEAL (CCCSCAN DEF OLDREF))))
NEWREF) (* ;
"No change, just return reference map")
(RETURN OLDREF]
((NEQ (fetch (REFMAP CODEARRAY) of (CADR OLDREF))
DEF)
(ERROR '"Inconsistent reference map" (CONS OLDREF FN]
(* ;
"Change all references in the map OLDREF to refer to NEWREF")
[for MAP in (CDR OLDREF)
do (SETQ DEF (fetch CODEARRAY of MAP))
[COND
((OR (fetch NAMELOCS of MAP)
(fetch CONSTLOCS of MAP)
(fetch DEFLOCS of MAP))
(OR (LITATOM NEWREF)
(ERROR "Can't changename a symbol to a non-symbol in compiled code" NEWREF
]
[for LC in (fetch NAMELOCS of MAP)
do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMVALINDEX NEWREF]
[for LC in (fetch CONSTLOCS of MAP)
do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMPNAMEINDEX NEWREF]
[for LC in (fetch DEFLOCS of MAP)
do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMDEFINDEX NEWREF]
(for LC in (fetch PTRLOCS of MAP)
do (UNINTERRUPTABLY
(* ;; "Decrement ref count of old literal, add new. Order here is such that the worst that happens if it is somehow aborted (despite the UNINTERRUPTABLY) is that the old and new literals never get collected")
(\ADDREF NEWREF)
(\DELREF (PROG1 (CODEBASELT3 DEF LC)
(CODEBASESETA3 DEF LC NEWREF))))]
(RETURN OLDREF])
(CCCSUBFN?
(LAMBDA (X) (* ; "Edited 9-Jun-88 20:53 by drc:") (DECLARE (USEDFREE ALL-CODE-BASES SUBMAPS OLDREF)) (* ;; "X is a literal found in the code. If X denotes a compiled subfunction, adds X's analysis to SUBMAPS. Subfunctions are either a symbol fnA0nnn or a compiled function object produced by PavCompiler.") (LET ((BASE (CL:TYPECASE X (COMPILED-CLOSURE (\GET-COMPILED-CODE-BASE X)) (LITATOM (AND (SETQ X (\SUBFNDEF X)) (\GET-COMPILED-CODE-BASE X))) (T (\CODEBLOCKP X))))) (if (AND BASE (NOT (FMEMB BASE ALL-CODE-BASES))) then (push ALL-CODE-BASES BASE) (* ;; "break circles by remembering what we've already analyzed in ALL-CODE-BASES") (SETQ SUBMAPS (NCONC SUBMAPS (CCCSCAN BASE OLDREF))))))
)
(\SUBFNDEF
(LAMBDA (X) (* bvm%: " 7-Jul-86 16:31") (AND (LITATOM X) (EQ (NTHCHARCODE X -5) (CHARCODE A)) (NOT (find I C from -4 to -1 suchthat (OR (ILESSP (SETQ C (NTHCHARCODE X I)) (CHARCODE 0)) (IGREATERP C (CHARCODE 9))))) (\GET-COMPILED-DEFINITION X)))
)
(CCCSCAN
[LAMBDA (DEF OLDREF)
(DECLARE (SPECVARS SUBMAPS OLDREF)) (* ;
"Edited 13-Nov-92 14:09 by sybalsky:mv:envos")
(* ;; "Scan the code block DEF for instances of the symbol OLDREF. Return a list of the instances and their locations, for use in doing CHANGENAME, e.g.")
(PROG ((CA DEF)
CONSTLOCS DEFLOCS PTRLOCS SUBMAPS NAMELOCS TAG B NAME CODELOC)
(SETQ CODELOC (fetch (FNHEADER STARTPC) of CA))
[COND
((LITATOM OLDREF)
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by (CONSTANT (BYTESPERNAMEENTRY))
do (OR (SETQ NAME (\INDEXATOMVAL (CODEBASEGETNAME CA NT1)))
(RETURN))
(AND (EQ NAME OLDREF)
(push NAMELOCS NT1]
LP (SETQ B (CODEBASELT CA CODELOC))
(SETQ TAG (\FINDOP B))
(add CODELOC (fetch OPNARGS of TAG)
1)
(SELECTQ (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG))
(-X- (RETURN (CONS (create REFMAP
CODEARRAY _ CA
NAMELOCS _ NAMELOCS
CONSTLOCS _ CONSTLOCS
DEFLOCS _ DEFLOCS
PTRLOCS _ PTRLOCS)
SUBMAPS)))
((FN FNX)
[SETQ NAME (CODEBASEGETATOM CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
[COND
([AND (LITATOM OLDREF)
(EQP NAME (NEW-SYMBOL-CODE OLDREF (\ATOMDEFINDEX OLDREF]
(push DEFLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
(CCCSUBFN? (\INDEXATOMDEF NAME)))
(ATOM [SETQ NAME (CODEBASEGETATOM CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
[COND
([AND (LITATOM OLDREF)
(EQ NAME (NEW-SYMBOL-CODE OLDREF (\ATOMPNAMEINDEX OLDREF]
(push CONSTLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
(CCCSUBFN? (\INDEXATOMPNAME NAME)))
(GCONST [COND
((EQ [SETQ NAME (CODEBASELT3 CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
OLDREF)
(push PTRLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM]
(CCCSUBFN? NAME))
NIL)
(GO LP])
(\CODEBLOCKP
(LAMBDA (PTR) (* ; "Edited 5-Apr-88 18:49 by bvm") (* ;; "Returns PTR if it is a pointer to a raw code block, else NIL. Code blocks come in two varieties: code hunks and code arrayblocks. Hunks are easy to check, because they have a distinct type. Arrayblocks are tricky to check, because they are typeless. The code here assumes that if you pass a typeless pointer, it is a pointer to the start of an object. If you pass a pointer to the middle of a bitmap, for example, you could, if you were very unlucky, get a false positive.") (AND (LET ((TEM (NTYPX PTR))) (if (EQ TEM 0) then (* ;; "Maybe arrayblock. Carefully check that: it is in the range for arrayspace; its header (the previous cell) exists and contains the magic arrayblock password, the block's type is code, the block is in use, and its trailer is well-formed.") (AND (>= (\HILOC PTR) \FirstArraySegment) (PROGN (SETQ TEM (\ADDBASE PTR (- \ArrayBlockHeaderWords))) (OR (>= (fetch (POINTER WORDINPAGE) of PTR) \ArrayBlockHeaderWords) (\VALIDADDRESSP TEM))) (EQ (fetch (ARRAYBLOCK PASSWORD) of TEM) \ArrayBlockPassword) (EQ (fetch (ARRAYBLOCK GCTYPE) of TEM) CODEBLOCK.GCT) (fetch (ARRAYBLOCK INUSE) of TEM) (\VALIDADDRESSP (SETQ TEM (fetch (ARRAYBLOCK TRAILER) of TEM))) (EQ (fetch (ARRAYBLOCK PASSWORD) of TEM) \ArrayBlockPassword)) elseif (fetch DTDHUNKP of (SETQ TEM (\GETDTD TEM))) then (* ; "It's a hunk, check the hunk's gc type") (EQ (fetch DTDGCTYPE of TEM) CODEBLOCK.GCT))) PTR))
)
)
(DEFINEQ
(\MAP-CODE-POINTERS
[LAMBDA (CODEBLOCK MAPFN) (* ;
"Edited 13-Nov-92 14:11 by sybalsky:mv:envos")
(* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each pointer we find (i.e., GCONST). MAPFN is called with three args: the pointer, CODEBLOCK, and the byte offset in CODEBLOCK where the pointer lives.")
(COND
((NEQ [LET ((TYPENO (NTYPX CODEBLOCK)))
(COND
[(EQ TYPENO 0)
(fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS
\ArrayBlockHeaderWords
]
(T (fetch DTDGCTYPE of (\GETDTD TYPENO]
CODEBLOCK.GCT)
(ERROR "ARG NOT Compiled Code Block" CODEBLOCK))
(T (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK))
TAG)
LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC)))
(add CODELOC 1)
(SELECTQ (fetch OPCODENAME of TAG)
(-X- (RETURN))
(GCONST (CL:FUNCALL MAPFN (CODEBASELT3 CODEBLOCK CODELOC)
CODEBLOCK CODELOC))
NIL)
(add CODELOC (fetch OPNARGS of TAG))
(GO LP])
(\MAP-CODE-LITERALS
[LAMBDA (CODEBLOCK MAPFN) (* ;
"Edited 13-Nov-92 15:35 by sybalsky:mv:envos")
(* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each literal we find (i.e., GCONST). MAPFN is called with four args: the literal, CODEBLOCK, the byte offset in CODEBLOCK where the literal lives, and the type of literal, one of ATOM, FN or POINTER. If you're only interested in pointers, the speedier \MAP-CODE-POINTERS is more appropriate.")
(COND
((NEQ [LET ((TYPENO (NTYPX CODEBLOCK)))
(COND
[(EQ TYPENO 0)
(fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS
\ArrayBlockHeaderWords
]
(T (fetch DTDGCTYPE of (\GETDTD TYPENO]
CODEBLOCK.GCT)
(ERROR "ARG NOT Compiled Code Block" CODEBLOCK))
(T (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK))
TAG)
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by (BYTESPERNAMEENTRY)
do (CL:FUNCALL MAPFN (OR (\INDEXATOMVAL (GETNAMEENTRY CODEBLOCK NT1))
(RETURN))
CODEBLOCK NT1 'ATOM))
LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC)))
(add CODELOC (fetch OPNARGS of TAG)
1)
(SELECTQ (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG))
(-X- (RETURN))
((FN FNX)
(CL:FUNCALL MAPFN [\INDEXATOMDEF (CODEBASELT3 CODEBLOCK (IDIFFERENCE CODELOC
(
BYTESPERCODEATOM
]
CODEBLOCK
(IDIFFERENCE CODELOC (BYTESPERCODEATOM))
'FN))
(ATOM (CL:FUNCALL MAPFN [\INDEXATOMPNAME (CODEBASELT3 CODEBLOCK (IDIFFERENCE
CODELOC
(
BYTESPERCODEATOM
]
CODEBLOCK
(IDIFFERENCE CODELOC (BYTESPERCODEATOM))
'ATOM))
(GCONST (CL:FUNCALL MAPFN (\VAG2 (CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 4))
(CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 2)))
CODEBLOCK
(IDIFFERENCE CODELOC 4)
'POINTER))
NIL)
(GO LP])
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK%: CALLSCCODE CALLSCCODE RUNION)
(BLOCK%: CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN)
)
(* ;;
"MACROS/OPTIMIZERS for getting and setting symbol entries in a compiled-code block. These are parameterized to allow for 2-, 3-, and 4-byte symbol representations."
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD REFMAP (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS CODEBASELT MACRO [OPENLAMBDA (CODEBASE OFFSET)
(COND
((fetch (FNHEADER BYTESWAPPED) of CODEBASE)
(\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3)))
(T (\GETBASEBYTE CODEBASE OFFSET])
(PUTPROPS CODEBASELT2 MACRO [OPENLAMBDA (DEF LC)
(LOGOR (LLSH (CODEBASELT DEF LC)
BITSPERBYTE)
(CODEBASELT DEF (ADD1 LC])
(PUTPROPS CODEBASESETA MACRO [OPENLAMBDA (CODEBASE OFFSET NEWVALUE)
(COND
((fetch (FNHEADER BYTESWAPPED) of CODEBASE)
(\PUTBASEBYTE CODEBASE (LOGXOR OFFSET 3)
NEWVALUE))
(T (\PUTBASEBYTE CODEBASE OFFSET NEWVALUE])
(PUTPROPS CODEBASESETA2 MACRO [OPENLAMBDA (DEF LC VALUE)
(CODEBASESETA DEF LC (LRSH VALUE BITSPERBYTE))
(CODEBASESETA DEF (ADD1 LC)
(IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE])
(PUTPROPS CODEBASELT3 MACRO [OPENLAMBDA (DEF LC)
(BIG-VMEM-CODE [\VAG2 (LOGOR (LLSH (CODEBASELT DEF LC)
BITSPERBYTE)
(CODEBASELT DEF (ADD1 LC)))
(LOGOR (LLSH (CODEBASELT DEF
(IPLUS 2 LC))
BITSPERBYTE)
(CODEBASELT DEF (IPLUS 3 LC]
(\VAG2 (CODEBASELT DEF LC)
(LOGOR (LLSH (CODEBASELT DEF (IPLUS 1 LC))
BITSPERBYTE)
(CODEBASELT DEF (IPLUS 2 LC])
(PUTPROPS CODEBASELT4 MACRO [OPENLAMBDA (DEF LC)
(BIG-VMEM-CODE [\VAG2 (LOGOR (LLSH (CODEBASELT DEF LC)
BITSPERBYTE)
(CODEBASELT DEF (ADD1 LC)))
(LOGOR (LLSH (CODEBASELT DEF
(IPLUS 2 LC))
BITSPERBYTE)
(CODEBASELT DEF (IPLUS 3 LC]
(\VAG2 (CODEBASELT DEF LC)
(LOGOR (LLSH (CODEBASELT DEF (IPLUS 1 LC))
BITSPERBYTE)
(CODEBASELT DEF (IPLUS 2 LC])
(PUTPROPS CODEBASESETA3 MACRO [OPENLAMBDA (DEF LC VALUE)
(CODEBASESETA DEF LC (\HILOC VALUE))
(CODEBASESETA DEF (ADD1 LC)
(LRSH (\LOLOC VALUE)
BITSPERBYTE))
(CODEBASESETA DEF (IPLUS 2 LC)
(IMOD (\LOLOC VALUE)
(CONSTANT (LLSH 1 BITSPERBYTE])
(PUTPROPS CODEBASESETA4 MACRO [OPENLAMBDA (DEF LC VALUE)
(CODEBASESETA DEF LC (LRSH (\HILOC VALUE)
BITSPERBYTE))
[CODEBASESETA DEF (ADD1 LC)
(IMOD (\HILOC VALUE)
(CONSTANT (LLSH 1 BITSPERBYTE]
(CODEBASESETA DEF (IPLUS 2 LC)
(LRSH (\LOLOC VALUE)
BITSPERBYTE))
(CODEBASESETA DEF (IPLUS 3 LC)
(IMOD (\LOLOC VALUE)
(CONSTANT (LLSH 1 BITSPERBYTE])
)
(DEFOPTIMIZER CODEBASESETATOM (DEFINITION OFFSET SYMBOL &ENVIRONMENT ENV)
[COND
[(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
`(CODEBASESETA4 ,DEFINITION ,OFFSET ,SYMBOL]
[(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
`(CODEBASESETA3 ,DEFINITION ,OFFSET ,SYMBOL]
(T `(CODESETA2 ,DEFINITION ,OFFSET ,SYMBOL])
(DEFOPTIMIZER CODEBASEGETATOM (DEFINITION OFFSET SYMBOL &ENVIRONMENT ENV)
(* ;; "Get an atom out of a compiled function definition.")
[COND
[(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
`(CODEBASELT4 ,DEFINITION ,OFFSET]
[(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
`(CODEBASELT3 ,DEFINITION ,OFFSET]
(T `(CODEBASELT2 ,DEFINITION ,OFFSET ,SYMBOL])
(DEFOPTIMIZER CODEBASEGETNAME (BASE OFFSET &ENVIRONMENT ENV)