root/trunk/lisp/lcadr/lqfmac.lisp @ 204

Revision 204, 3.3 KB (checked in by rjs, 3 years ago)

Update.

Line 
1;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
2;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **
3;;; ***CAUTION!! This file runs only on LISPM.  The MACLISP version is LMCONS;QFMAC***
4;;;    macros for QF, CC: version of console program that runs on machine
5
6
7;SPECIAL VARIABLES FOR ARRAY STUFF
8
9(DECLARE (SPECIAL QF-ARRAY-HEADER QF-ARRAY-DISPLACED-P QF-ARRAY-HAS-LEADER-P
10  QF-ARRAY-NUMBER-DIMS QF-ARRAY-HEADER-ADDRESS QF-ARRAY-DATA-ORIGIN QF-ARRAY-LENGTH))
11
12;FUNCTIONS TO EXAMINE AND DEPOSIT FIELDS OF A Q
13
14;BUILD A Q, GIVEN THE CONTENTS OF ITS FIELDS.
15;THE CDR-CODE DEFAULTS TO CDR-ERROR.
16(DEFMACRO QF-MAKE-Q (POINTER DATA-TYPE &OPTIONAL CDR-CODE)
17     (COND (CDR-CODE
18            `(QF-SMASH-CDR-CODE (QF-SMASH-DATA-TYPE ,POINTER ,DATA-TYPE) ,CDR-CODE))
19           (T `(QF-SMASH-DATA-TYPE ,POINTER ,DATA-TYPE))))
20
21(DEFMACRO QF-DATA-TYPE (Q) `(LDB 3005 ,Q))
22
23(DEFMACRO QF-POINTER (Q) `(LET ((**FOO** ,Q))
24                               (LOGIOR (LSH (LDB 1414 **FOO**) 14) (LDB 0014 **FOO**))))
25
26(DEFMACRO QF-CDR-CODE (Q) `(LDB 3602 ,Q))
27
28(DEFMACRO QF-FLAG-BIT (Q) `(LDB 3501 ,Q))
29
30(DEFMACRO QF-TYPED-POINTER (Q) `(LOGAND 3777777777 ,Q))
31
32;SMASH VAL INTO POINTER AND DATA-TYPE OF Q
33(DEFMACRO QF-SMASH-TYPED-POINTER (Q VAL) `(DPB ,VAL 0035 ,Q))
34
35(DEFMACRO QF-SMASH-CDR-CODE (Q VAL) `(DPB ,VAL 3602 ,Q))
36
37(DEFMACRO QF-SMASH-FLAG-BIT (Q VAL) `(DPB ,VAL 3501 ,Q))
38
39(DEFMACRO QF-SMASH-POINTER (Q VAL) `(DPB ,VAL 0030 ,Q))
40
41(DEFMACRO QF-SMASH-DATA-TYPE (Q VAL) `(DPB ,VAL 3005 ,Q))
42
43(DECLARE (SPECIAL QF-NIL))
44(SETQ QF-NIL (QF-MAKE-Q 0 DTP-SYMBOL))          ;******* NIL KNOWN TO BE AT ZERO *******
45
46;;;; ANALOGUES OF %P-POINTER, %P-STORE-POINTER, ETC.
47
48(DEFMACRO QF-P-POINTER (LOC) `(QF-POINTER (QF-MEM-READ ,LOC)))
49
50(DEFMACRO QF-P-DATA-TYPE (LOC) `(QF-DATA-TYPE (QF-MEM-READ ,LOC)))
51
52(DEFMACRO QF-P-FLAG-BIT (LOC) `(QF-FLAG-BIT (QF-MEM-READ ,LOC)))
53
54(DEFMACRO QF-P-CDR-CODE (LOC) `(QF-CDR-CODE (QF-MEM-READ ,LOC)))
55
56(DEFMACRO QF-P-CONTENTS (LOC) `(QF-TYPED-POINTER (QF-MEM-READ ,LOC)))
57
58(DEFMACRO QF-P-STORE-POINTER (LOC VAL)
59     `(LET ((ADDR* ,LOC))
60           (QF-MEM-WRITE (QF-SMASH-POINTER (QF-MEM-READ ADDR*)
61                                           ,VAL)
62                         ADDR*)))
63
64(DEFMACRO QF-P-STORE-CONTENTS (LOC VAL)
65     `(LET ((ADDR* ,LOC))
66           (QF-MEM-WRITE (QF-SMASH-TYPED-POINTER (QF-MEM-READ ADDR*)
67                                                 ,VAL)
68                         ADDR*)))
69
70(DEFMACRO QF-P-STORE-DATA-TYPE (LOC VAL)
71     `(LET ((ADDR* ,LOC))
72           (QF-MEM-WRITE (QF-SMASH-DATA-TYPE (QF-MEM-READ ADDR*)
73                                             ,VAL)
74                         ADDR*)))
75
76(DEFMACRO QF-P-STORE-FLAG-BIT (LOC VAL)
77     `(LET ((ADDR* ,LOC))
78           (QF-MEM-WRITE (QF-SMASH-FLAG-BIT (QF-MEM-READ ADDR*)
79                                            ,VAL)
80                         ADDR*)))
81
82(DEFMACRO QF-P-STORE-CDR-CODE (LOC VAL)
83     `(LET ((ADDR* ,LOC))
84           (QF-MEM-WRITE (QF-SMASH-CDR-CODE (QF-MEM-READ ADDR*)
85                                            ,VAL)
86                         ADDR*)))
87
88(DEFMACRO QF-NULL (X) `(= ,X QF-NIL))
89
90(DEFMACRO SELECTN (ITEM . BODY)
91   `((LAMBDA (*SELECTN-ITEM*)
92        (COND . ,(MAPCAR
93                  '(LAMBDA (CLAUSE)
94                       (COND ((EQ (CAR CLAUSE) 'OTHERWISE)
95                              `(T . ,(CDR CLAUSE)))
96                             ((ATOM (CAR CLAUSE))
97                              `((= *SELECTN-ITEM* ,(CAR CLAUSE)) . ,(CDR CLAUSE)))
98                             (T `((OR . ,(MAPCAR '(LAMBDA (ITEM) `(= *SELECTN-ITEM* ,ITEM))
99                                                 (CAR CLAUSE))) . ,(CDR CLAUSE)))))
100                         BODY)))
101     ,ITEM))
102
103
104;Really wants to be a bignum LSH.  On LISPM, LSH doesnt win for bignums, ASH does.
105; In MACLISP, LSH wins sufficiently.
106(DEFMACRO CC-SHIFT (QUAN AMT)
107  `(#Q ASH #M LSH ,QUAN ,AMT))
Note: See TracBrowser for help on using the browser.