-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathCOMMON-MAKE
245 lines (220 loc) · 14.1 KB
/
COMMON-MAKE
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
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Oct-2023 16:40:48" {LU}COMMON-MAKE.;2 14315
:EDIT-BY "mth"
:CHANGES-TO (VARS COMMON-MAKECOMS)
:PREVIOUS-DATE "11-Dec-87 14:48:16" {LU}COMMON-MAKE.;1)
(PRETTYCOMPRINT COMMON-MAKECOMS)
(RPAQQ COMMON-MAKECOMS [
(* ;; "FUNCTIONS TO HANDLE WRITING STANDARD COMMONLISP SOURCE FILES")
(FNS COMMON-FILE-COMMAND COMMON-MAKEFILE)
(PROP MAKEFILE-ENVIRONMENT COMMON-MAKE)
(DECLARE%: DONTCOPY (ALISTS (EDITHISTALIST COMMON-MAKE])
(* ;; "FUNCTIONS TO HANDLE WRITING STANDARD COMMONLISP SOURCE FILES")
(DEFINEQ
(COMMON-FILE-COMMAND
[LAMBDA (COMMAND) (* ; "Edited 11-Dec-87 14:46 by DJVB")
(* THE NEW COMMONLISP COMMANDS ARE MOSTLY MACROS TO THINGS THIS HANDLES)
(SELECTQ (SETQ TYPE (GETFILEPKGTYPE (CAR COMMAND)
'COMMAND))
(FNS [for FN in (PRETTYCOM1 COMMAND T T) bind DEF
do (SETQ DEF (GETDEF FN 'FNS))
(CL:PPRINT (SELECTQ (CAR DEF)
(CL:LAMBDA `(CL:DEFUN (\, FN) ,@(CDR DEF) )
)
(LAMBDA `(CL:DEFUN (\, FN) (&OPTIONAL ,@(CADR DEF))
,@(CDDR DEF))
)
(HELP "UNSUPPORTED LAMBDA" (CAR DEF])
(DECLARE%: [FOR DEC IN (PRETTYCOM1 COMMAND T T) BIND (CND _ '(CL:LOAD CL:EVAL))
DO (SELECTQ DEC
((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN)
(HELP))
((FIRST NOTFIRST))
(COMPILERVARS (RETURN))
((COPY DOCOPY)
(SETQ CND (CL:ADJOIN 'CL:LOAD CND)))
((DOEVAL@COMPILE EVAL@COMPILE)
(SETQ CND (CL:ADJOIN 'CL:COMPILE CND)))
((DOEVAL@LOAD EVAL@LOAD)
(SETQ CND (CL:ADJOIN 'CL:LOAD CND)))
(DONTCOPY (SETQ CND (CL:REMOVE 'CL:LOAD CND)))
(DONTEVAL@COMPILE
(SETQ CND (CL:REMOVE 'CL:COMPILE CND)))
(DONTEVAL@LOAD (SETQ CND (CL:REMOVE 'CL:EVAL CND)))
(PROGN (CL:FORMAT T "~&(EVAL-WHEN ~S " CND)
(COMMON-FILE-COMMAND DEC)
(CL:FORMAT T ")"])
(SPECVARS [CL:PPRINT `(PROCLAIM (SPECIAL ,@(PRETTYCOM1 COMMAND T T])
(GLOBALVARS [CL:PPRINT `(PROCLAIM (USER::GLOBAL ,@(PRETTYCOM1 COMMAND T T])
(LOCALVARS [CL:PPRINT `(PROCLAIM (USER::LEXICAL ,@(PRETTYCOM1 COMMAND T T])
((PROP IFPROP)
[LET
((IFFLG (EQ (CAR COMMAND)
PROP))
(PROP (CADR COMMAND))
(ATMS (PRETTYCOM1 (CDR COMMAND)
T T)))
(IF (LISTP PROP)
THEN [FOR PRP IN PROP
DO (for ATM in ATMS when (OR IFFLG (GET ATM PRP))
do (CL:PPRINT `(CL:SETF (GET ',ATM ',PRP)
',(GET ATM PRP]
ELSEIF (EQ PROP 'ALL)
THEN (* ALL PROPERTIES)
[FOR ATM IN ATMS
DO (FOR PAIR ON (GETPROPLIST ATM) BY (CDDR PAIR)
UNLESS (MEMB (CAR PAIR)
SYSPROPS)
DO (CL:PPRINT `(CL:SETF [GET ',ATM ',(CAR PAIR]
',(CADR PAIR]
ELSE (for ATM in ATMS when (OR (NOT IFFLG)
(GET ATM PROP))
do (CL:PPRINT `(CL:SETF (GET ',ATM ',PROP)
',(GET ATM PROP])
(PROPS [FOR AP in (PRETTYCOM1 (CDR COMMAND)
T T)
do (CL:PPRINT `(CL:SETF [GET ',(CAR AP) ',(CADR AP]
',(GET (CAR AP)
(CADR AP])
(P (for PTHIS in (PRETTYCOM1 COMMAND T) do (CL:PPRINT PTHIS)))
(MACROS (HELP "I THOUGHT YOU TRANSORED ALL THOSE MACROS" COMMAND))
((VARS ARRAY)
[for VAR in (PRETTYCOM1 COMMAND T T)
do (CL:PPRINT (if (LITATOM VAR)
then `(CL:DEFPARAMETER (\, VAR) ',(GETTOPVAL VAR) )
else `(CL:DEFPARAMETER (\, (CAR VAR)) ',(CADR VAR) )
])
(INITVARS [FOR VAR IN (PRETTYCOM1 COMMAND T T)
DO (CL:PPRINT (IF (LITATOM VAR)
THEN `(CL:DEFVAR (\, VAR) NIL)
ELSE (IF (SUPERPRINTEQ (CAR VAR)
COMMENTFLG)
THEN VAR
ELSE `(CL:DEFVAR (\,@ VAR) )
])
(CONSTANTS [VARS (FOR VAR IN (PRETTYCOM1 COMMAND T T)
DO (CL:PPRINT (IF (LITATOM VAR)
THEN `(CL:DEFCONSTANT (\, VAR) ',(GETTOPVAL VAR) )
ELSE `(CL:DEFCONSTANT (\, (CAR VAR)) ',(CADR VAR) )
])
((UGLYVARS HORRIBLEVARS)
[LET ((*PRINT-CIRCLE* T))
(DECLARE (SPECVARS *PRINT-CIRCLE*))
(FOR VAR IN (PRETTYCOM1 COMMAND T T)
DO (CL:PPRINT `(DEFPARAMETER ,VAR ',(GETTOPVAL VAR])
(ADDVARS [for AV in (PRETTYCOM1 COMMAND T T)
do (CL:PPRINT (if (CDDR AV)
then `[SETQ ,(CAR AV) (UNION ',(CDR AV) ,(CAR AV]
else `(CL:PUSHNEW ',(CADR AV) ,(CAR AV])
(APPENDVARS [FOR AV IN (PRETTYCOM1 COMMAND T T)
DO (CL:PPRINT `(SETQ ,(CAR AV) (CL:APPEND ,(CAR AV) ',(CDR AV])
(E (HELP "I HOPE THIS %"E%"KNOWS WHAT ITS DOING" COMMAND)
(FOR EXP IN (PRETTYCOM1 COMMAND T) DO (EVAL EXP)))
((FILEPKGCOMS I.S.OPRS TEMPLATES BLOCKS EXPORT EDITHIST)
(* JUST IGNORE THESE)
NIL)
((RECORDS INITRECORDS SYSRECORDS)
(HELP "I THOUGHT YOU TRANSORED ALL THOSE RECORDS" COMMAND))
(COMS (FOR COM IN (PRETTYCOM1 COMMAND T) DO (COMMON-FILE-COMMAND COM)))
(ORIGINAL (* COMS, BUT WITHOUT ANY USER DEFINED
COMMANDS)
(LET* ((PRTTYTEM (PRETTYCOM1 COMMAND T))
(ORIGFLG T))
(DECLARE (SPECVARS ORIGFLG))
(for COM in PRTTYTEM do (COMMON-FILE-COMMAND COM))))
(FILES
(* INSIDE LISTP%: FROM dir SOURCE COMPILED LOAD LOADCOMP LOADFROM SYSLOAD PROP
ALLPROP)
(* REQUIRE IS NOT IDENTICAL, BUTS IS AS CLOSE AS CL GETS)
[for F in (PRETTYCOM1 COMMAND T T) bind DIR PLACE
do (if (LISTP F)
then (if (SETQ PLACE (MEMB 'FROM F))
then (SETQ DIR (LIST (CADR PLACE)))
else (HELP "FILES OPTION?" F))
else (CL:PPRINT `(CL:REQUIRE ,F ,@DIR])
(* (IF (EQ (CADR COMMAND)
'*)
THEN (BOUT *STANDARD-OUTPUT* (CHARCODE FORM))
ELSE (TERPRI)
(TERPRI)
(TERPRI))
(PRINTDEF COMMAND NIL T)
(TERPRI)
(TERPRI))
(LET (MACRO)
(if (SETQ MACRO (CDR (ASSOC (CAR COMMAND)
PRETTYDEFMACROS)))
then (for COM in (SUBPAIR (CAR MACRO)
(PRETTYCOM1 COMMAND T T)
(CDR MACRO)) do (COMMON-FILE-COMMAND COM))
else (HELP "CAN'T HANDLE" (CAR COMMAND])
(COMMON-MAKEFILE
[LAMBDA (FILE DEBUG) (* ; "Edited 11-Dec-87 13:25 by DJVB")
(PROG ((*PRINT-SEMICOLON-COMMENTS* 'ALL)
(*PRINT-ARRAY* T)
(*PRINT-STRUCTURE* T)
**COMMENTFLG** FONTCHANGEFLG *PRINT-LENGTH* *PRINT-LEVEL* %#RPARS)
(DECLARE (SPECVARS *PRINT-SEMICOLON-COMMENTS* *PRINT-ARRAY* *PRINT-STRUCTURE*
**COMMENTFLG** FONTCHANGEFLG *PRINT-LENGTH* *PRINT-LEVEL* %#RPARS))
(RETURN (PROG [(*STANDARD-OUTPUT* (OPENSTREAM (PACKFILENAME 'EXTENSION 'LISP 'BODY FILE)
'OUTPUT]
(DECLARE (SPECVARS *STANDARD-OUTPUT*))
(RETURN (CL:UNWIND-PROTECT (PROG (DATES FILEILNAME PKGNAME BASE (*PACKAGE*
*PACKAGE*)
(*PRINT-BASE* *PRINT-BASE*)
(*READTABLE* (FIND-READTABLE "LISP"))
)
(DECLARE (SPECVARS *PACKAGE* *PRINT-BASE*
*READTABLE*))
(SETQ DATES (GETPROP (SETQ FILEILNAME
(CL:INTERN
(STRING FILE)
"IL"))
'FILEDATES))
(SETQ PKGNAME
(OR (LISTGET (GETPROP FILEILNAME
'MAKEFILE-ENVIRONMENT)
:PACKAGE)
"USER"))
(SETQ BASE (OR (LISTGET (GETPROP
FILEILNAME
'
MAKEFILE-ENVIRONMENT
)
:BASE)
10))
(CL:FORMAT T
";;; -*- Mode: LISP; Syntax: Common-lisp; Package: ~A; Base: ~A -*-"
PKGNAME BASE)
(SETQ *PACKAGE* (CL:FIND-PACKAGE PKGNAME))
(SETQ *PRINT-BASE* BASE)
(CL:FORMAT T
"~%%;;; File converted ~A from source ~A"
(DATE)
FILE)
(AND DATES (CL:FORMAT T
"~&;;; Original source ~A created ~A"
(CDAR DATES)
(CAAR DATES)))
(for P
in (LISTP (GETTOPVAL (FILECOMS FILE)))
do (COMMON-FILE-COMMAND P))
(RETURN (FULLNAME *STANDARD-OUTPUT*)))
(CLOSEF *STANDARD-OUTPUT*])
)
(PUTPROPS COMMON-MAKE MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(DECLARE%: DONTCOPY
(ADDTOVAR EDITHISTALIST
(COMMON-MAKE ("11-Dec-87 12:54:22" DJVB {DSK}<XAVIER>COMMON-MAKE.;1 (COMMON-FILE-COMMAND
COMMON-MAKEFILE))
("11-Dec-87 13:35:35" DJVB {DSK}<XAVIER>COMMON-MAKE.;2 (COMMON-FILE-COMMAND
COMMON-MAKEFILE)
(GETTING DETAILS RIGHT))
("11-Dec-87 13:40:48" DJVB {DSK}<XAVIER>COMMON-MAKE.;3 (COMMON-FILE-COMMAND))
("11-Dec-87 14:09:04" DJVB {DSK}<XAVIER>COMMON-MAKE.;4 (COMMON-FILE-COMMAND))
("11-Dec-87 14:48:44" DJVB {DSK}<XAVIER>COMMON-MAKE.;5 (COMMON-FILE-COMMAND)
(FIXED FILE COMMENTS AND CL:DEFVAR ET AL))))
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (722 13353 (COMMON-FILE-COMMAND 732 . 8948) (COMMON-MAKEFILE 8950 . 13351)))))
STOP