-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathSIMPLIFY
131 lines (112 loc) · 4.79 KB
/
SIMPLIFY
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
(FILECREATED "19-Feb-87 09:42:40" {QV}<LFG>PARSER>SIMPLIFY.;1 4714
previous date: " 6-NOV-79 17:25:50" <LISPUSERS>SIMPLIFY.;3)
(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SIMPLIFYCOMS)
(RPAQQ SIMPLIFYCOMS ((* Tools for symbolic simplification of LISP forms)
(FNS SIMPLIFY)
(FNS APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL)
(BLOCKS (APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL))))
(* Tools for symbolic simplification of LISP forms)
(DEFINEQ
(SIMPLIFY
[LAMBDA (FORM) (* bas: " 6-NOV-79 16:51")
(* Eventually this will be a general symbolic
simplification package, but for now its just a dummy
entry)
FORM])
)
(DEFINEQ
(APPLYFORM
[LAMBDA (FN ARG1) (* bas: " 6-NOV-79 17:24")
(PROG (FNARG FNFORM)
(RETURN (if (AND (EQ (CAR (LISTP FN))
(QUOTE LAMBDA))
[LISTP (CAR (LISTP (CDR FN]
(NULL (CDADR FN))
(LITATOM (SETQ FNARG (CAADR FN)))
FNARG
(OR (PROGN (SETQ FNFORM (if (CDDDR FN)
then (CONS (QUOTE PROGN)
(CDDR FN))
else (CADDR FN)))
(SIMPLEP ARG1))
(ONCE FNARG FNFORM)))
then
(* We know that FN is a LAMBDA with one non-NIL litatom argument, and that either FNARG can be safely evaluated
multiple times or the function body only references it once.)
(if (EQ FNARG ARG1)
then (* Arg and arg name are same so body will do)
FNFORM
else (SUBSTVAL ARG1 FNARG FNFORM))
else (LIST FN ARG1])
(ONCE
[LAMBDA (ATOM FORM FLG) (* bas: "19-AUG-78 17:34")
(DECLARE (SPECVARS FLG))
(ONCE1 ATOM FORM)
(NEQ FLG (QUOTE FAILED])
(ONCE1
[LAMBDA (A L) (* bas: "18-SEP-79 17:03")
(for I in L do [if (LISTP I)
then (OR (OPAQUE I A)
(ONCE1 A I))
elseif (EQ A I)
then (SETQ FLG (if FLG
then (QUOTE FAILED)
else (QUOTE ONCE]
until (EQ FLG (QUOTE FAILED])
(OPAQUE
[LAMBDA (FORM VAR) (* rmk: " 5-AUG-79 22:11")
(* Determines if VAR substitution can take place in
FORM)
(SELECTQ (CAR FORM)
(QUOTE T)
([LAMBDA NLAMBDA]
(FMEMB VAR (CADR FORM)))
[PROG (for I in (CADR FORM) thereis (EQ VAR (if (LISTP I)
then (CAR I)
else I]
NIL])
(SIMPLEP
[LAMBDA (FORM) (* rmk: " 5-AUG-79 22:06")
(* Decides if a form is simple enough so that it can
be evaluated repeatedly rather than taking a LAMBDA
binding)
(OR (ATOM FORM)
(SELECTQ (CAR (LISTP FORM))
((QUOTE CAR CDR CADR CDDR)
(LITATOM (CADR FORM)))
NIL)
(STRINGP FORM])
(SUBSTVAL
[LAMBDA (NEW OLD FORM) (* bas: " 8-MAR-79 20:39")
(* Substitutes NEW for OLD in FORM.
Just like SUBST except is sensitive to opacity)
(if (LISTP FORM)
then [if (OPAQUE FORM OLD)
then FORM
else (PROG (NSCR OSCR)
(RETURN (if [SETQ OSCR (for I in FORM
thereis (NEQ I
(SETQ NSCR
(SUBSTVAL NEW
OLD I]
then (for I in FORM
collect (if (NULL OSCR)
then (SUBSTVAL NEW OLD I)
elseif (EQ OSCR I)
then (SETQ OSCR NIL)
NSCR
else I))
else FORM]
elseif (EQ FORM OLD)
then NEW
else FORM])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL)
]
(PUTPROPS SIMPLIFY COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (541 874 (SIMPLIFY 551 . 872)) (875 4521 (APPLYFORM 885 . 1935) (ONCE 1937 . 2140) (
ONCE1 2142 . 2557) (OPAQUE 2559 . 3085) (SIMPLEP 3087 . 3588) (SUBSTVAL 3590 . 4519)))))
STOP