1)package "BOOT" 2 3flattenSemi(tree) == 4 not(CONSP(tree)) => tree 5 tree is [";", t1, t2] => 6 t1 := flattenSemi(t1) 7 t2 := flattenSemi(t2) 8 t1 := 9 t1 is [";",:rest] => rest 10 [t1] 11 t2 := 12 t2 is [";",:rest] => rest 13 [t2] 14 [";", :t1, :t2] 15 tree is [";", :.] => BREAK() 16 [flattenSemi(el) for el in tree] 17 18-- 19-- Expansion of macros and removal of macrodefinitions 20-- 21 22expandMacros(tree) == 23 ATOM tree => 24 mdef := HGET($MacroTable, tree) 25 mdef => 26 repval := first(mdef) 27 null(rest(mdef)) => expandMacros(repval) 28 userError("macro call needs arguments") 29 tree 30 -- floating point numbers 31 [op, :args] := tree 32 EQ(op, ":BF") => tree 33 ATOM(op) => 34 mdef := HGET($MacroTable, op) 35 mdef => 36 repval := first(mdef) 37 margs := rest(mdef) 38 null(margs) => 39 [expandMacros(repval), :[expandMacros(x) for x in args]] 40 args := 41 args is [[",", :args1]] => postFlatten(first(args), ",") 42 args 43 #args = #margs => 44 expandMacros(SUBLISLIS(args, margs, repval)) 45 userError("invalid macro call, #args ~= #margs") 46 [op, :[expandMacros(x) for x in args]] 47 [expandMacros(x) for x in tree] 48 49-- 50-- Handling of extra definitions 51-- 52 53replaceArgDef1(args, edef) == 54 SYMBOLP args => 55 edef is [":", args, .] => edef 56 BREAK() 57 args is [",", args1, args2] => 58 EQ(args2, NTH(1, edef)) => [",", args1, edef] 59 [",", replaceArgDef1(args1, edef), args2] 60 BREAK() 61 62replaceArgDef(h1, edef) == 63 h1 is [name, args] => [name, replaceArgDef1(args, edef)] 64 BREAK() 65 66replaceArgDefs1(h1, edefs) == 67 for edef in edefs repeat 68 h1 := replaceArgDef(h1, edef) 69 h1 70 71replaceArgDefs(header, edefs) == 72 header is [":", h1, type] => [":", replaceArgDefs1(h1, edefs), type] 73 replaceArgDefs1(header, edefs) 74 75---------------------------------------------------------------------- 76-- 77-- Collect definitions from where list. Returns list of definitions 78-- which can not be converted to macros 79-- 80 81DEFPARAMETER($restore_list, nil) 82 83define_macro(name, def) == 84 if SYMBOLP(name) then 85 def := [def] 86 else if name is [op, :args] and SYMBOLP(op) then 87 args := 88 args is [[",", :args1]] => postFlatten(first(args), ",") 89 args 90 name := op 91 def := [def, :args] 92 else 93 SAY([name, def]) 94 userError("Invalid macro definition") 95 prev_def := HGET($MacroTable, name) 96 PUSH([name, :prev_def], $restore_list) 97 HPUT($MacroTable, name, def) 98 99do_walk_where_list(tree) == 100 lastIteration := false 101 ress := nil 102 while not(lastIteration) repeat 103 if tree is [";", tree1, el] then 104 tree := tree1 105 else 106 el := tree 107 lastIteration := true 108 el is ["==>", name, def] => define_macro(name, def) 109 el is ["==", name, def] => 110 define_macro(name, def) 111 el is [":", ., .] => 112 ress := [el, :ress] 113 el is [",", pel, item] => 114 item is [":", sym, type] => 115 sl := [sym] 116 while pel is [",", pel1, sym] repeat 117 sl := [sym, :sl] 118 pel := pel1 119 if not(SYMBOLP pel) then 120 FORMAT(true, '"strange where |,| item2") 121 BREAK() 122 sl := [pel, :sl] 123 for sym in sl repeat 124 ress := [[":", sym, type], :ress] 125 FORMAT(true, '"strange where |,| item1") 126 BREAK() 127 FORMAT(true, '"strange where item: ~S~&", el) 128 BREAK() 129 ress 130 131------------------------------------------------------------------ 132-- 133-- Remove macros and where parts from global definitions 134-- 135 136walkWhereList(name, def, env) == 137 $restore_list : local := nil 138 edefs := do_walk_where_list env 139 ress := expandMacros(["==", replaceArgDefs(name, edefs), def]) 140 for it in $restore_list repeat 141 [op, :def] := it 142 HPUT($MacroTable, op, def) 143 ress 144 145walkForm(tree) == 146 tree is ["==>", name, def] => 147 define_macro(name, def) 148 nil 149 tree is ["==", head, def] => expandMacros(tree) 150 tree is ["where", ["==", name, def], env] => 151 walkWhereList(name, def, env) 152 userError("Parsing error: illegal toplevel form") 153 nil 154 155-------------------------------------------------------------------- 156 157isNiladic(head1) == 158 SYMBOLP head1 => true 159 head1 is [., ["@Tuple"]] 160 161getCon(head1) == 162 SYMBOLP head1 => head1 163 first head1 164 165processGlobals1() == 166 for form in $globalDefs repeat 167 [., head, :.] := form 168 head1 := 169 head is [":", a, .] => a 170 head 171 con := getCon head1 172 -- at this stage distinction between domain and package does 173 -- not matter, so we treat packages as domains 174 if head is [":", ., "Category"] then 175 SETDATABASE(con, 'CONSTRUCTORKIND, "category") 176 else 177 SETDATABASE(con, 'CONSTRUCTORKIND, "domain") 178 SETDATABASE(con, 'NILADIC, isNiladic head1) 179 180processGlobals () == 181 $InteractiveMode : local := nil 182 $globalDefs := REVERSE $globalDefs 183 processGlobals1() 184 $globalDefs := [parseTransform postTransform x for x in $globalDefs] 185 untypedDefs := [] 186 for def in $globalDefs repeat 187 ["DEF", form, sig, sc, body] := def 188 cosig := CONS(nil, [categoryForm? ty for ty in rest(sig)]) 189 SETDATABASE(first form, 'COSIG, cosig) 190 if null first(sig) then 191 untypedDefs := [def, :untypedDefs] 192 else 193 handleKind(def) 194 195 for def in untypedDefs repeat 196 ["DEF", form, sig, sc, body] := def 197 nt := computeTargetMode(form, body) 198 if nt then 199 handleKind(["DEF", form, [nt, :rest sig], sc, body]) 200 else 201 SAY(["unhandled target", form]) 202 boo_comp_cats() 203 204 205handleKind(df is ['DEF,form,sig,sc,body]) == 206 [op,:argl] := form 207 208 null first(sig) => nil 209 if sig is [["Category"], :.] then 210 if body is ['add,cat,capsule] then 211 body := cat 212 sargl:= TAKE(# argl, $TriangleVariableList) 213 aList:= [[a,:sa] for a in argl for sa in sargl] 214 formalBody:= SUBLIS(aList,body) 215 if (not(opOf(formalBody) = "Join")) and _ 216 (not(opOf(formalBody) = "mkCategory")) then 217 formalBody := ['Join, formalBody] 218 signature' := SUBLIS(aList,sig) 219 constructorCategory := formalBody 220 else 221 signature' := sig 222 223 pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] 224 parSignature:= SUBLIS(pairlis,signature') 225 parForm:= SUBLIS(pairlis,form) 226 constructorModemap := removeZeroOne [[parForm,:parSignature],[true,op]] 227 SETDATABASE(op, 'CONSTRUCTORMODEMAP, constructorModemap) 228 SETDATABASE(op, 'CONSTRUCTORCATEGORY, constructorCategory) 229 230boo_comp_cats() == 231 $compiler_output_stream := MAKE_-BROADCAST_-STREAM() 232 $bootStrapMode : local := true 233 SAY(["boo_comp_cats"]) 234 hcats := [] 235 for def in $globalDefs repeat 236 ["DEF", form, sig, sc, body] := def 237 if sig is [["Category"], :.] then 238 SAY(["doing", form, sig]) 239 not("and"/[categoryForm? ty for ty in rest(sig)]) => 240 hcats := cons(def, hcats) 241 boo_comp1(def) 242 for def in hcats repeat boo_comp1(def) 243 244boo_comp1(x) == 245 $Index : local := 0 246 $MACROASSOC : local := [] 247 $compUniquelyIfTrue : local := nil 248 $postStack : local := nil 249 $topOp : local := nil 250 $semanticErrorStack : local := [] 251 $warningStack : local := [] 252 $exitMode : local := $EmptyMode 253 $exitModeStack : local := [] 254 $returnMode : local := $EmptyMode 255 $leaveLevelStack : local := [] 256 $CategoryFrame : local := [[[]]] 257 $insideFunctorIfTrue : local := false 258 $insideWhereIfTrue : local := false 259 $insideCategoryIfTrue : local := false 260 $insideCapsuleFunctionIfTrue : local := false 261 $e : local := $EmptyEnvironment 262 $genSDVar : local := 0 263 $previousTime : local := get_run_time() 264 compTopLevel(x, $EmptyMode, [[[]]]) 265 if $semanticErrorStack then displaySemanticErrors() 266 267-- for domains 268-- $lisplibCategory := modemap.mmTarget 269-- for categories 270-- $lisplibCategory:= formalBody 271 272computeTargetMode(lhs, rhs) == 273 PRETTYPRINT(["computeTargetMode", lhs]) 274 rhs is ['CAPSULE,:.] => MOAN(['"target category of ", lhs,_ 275 '" cannot be determined from definition"],nil) 276 rhs is ['SubDomain,D,:.] => computeTargetMode(lhs,D) 277 rhs is ['add,D,['CAPSULE,:.]] => computeTargetMode(lhs,D) 278 rhs is ['Record,:l] => ['RecordCategory,:l] 279 rhs is ['Union,:l] => ['UnionCategory,:l] 280 rhs is ['List,:l] => ['ListCategory,:l] 281 rhs is ['Vector,:l] => ['VectorCategory,:l] 282 283 rhs is [op, :argl] => 284 modemap := GETDATABASE(op, 'CONSTRUCTORMODEMAP) 285 modemap is [[form, sig, :.], [=true,.]] => 286 pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] 287 -- substitute 288 SUBLIS(pairlis, sig) 289 PRETTYPRINT("strange untyped def") 290 PRETTYPRINT([lhs, rhs, modemap]) 291 nil 292 BREAK() 293 294)if false 295 296 abbreviation ; +- 297 ancestors ; interp. 298 constructor ; unused 299 constructorcategory ; + 300 constructorkind ; + 301 constructormodemap ; +- (need to handle untyped definitions) 302 cosig ; + 303 defaultdomain ; + used only in interpreter, values is 304 computed in daase.lisp, but is unused 305 (getdatabase returns value from hardcoded list) 306 modemaps ; almost unused in the compiler -- used to 307 invalidate old modemaps when updating 308 *operation-hash* (which in turn is used 309 only in interpreter). 310 niladic ; + 311 object ; +- 312 operationalist ; interp. 313 314)endif 315 316DEFVAR($PrintOnly, false) 317DEFVAR($RawParseOnly, false) 318DEFVAR($PostTranOnly, false) 319DEFVAR($FlatParseOnly, false) 320DEFVAR($TranslateOnly, false) 321DEFVAR($noEarlyMacroexpand, false) 322DEFVAR($SaveParseOnly, false) 323DEFVAR($globalDefs, nil) 324DEFVAR($MacroTable) 325 326S_process(x) == 327 $Index : local := 0 328 $MACROASSOC : local := nil 329 $compUniquelyIfTrue : local := false 330 $postStack : local := nil 331 $topOp : local := nil 332 $semanticErrorStack : local := nil 333 $warningStack : local := nil 334 $exitMode : local := $EmptyMode 335 $exitModeStack : local := nil 336 $returnMode : local := $EmptyMode 337 $leaveLevelStack : local := nil 338 $CategoryFrame : local := [[[]]] 339 $insideFunctorIfTrue : local := false 340 $insideWhereIfTrue : local := false 341 $insideCategoryIfTrue : local := false 342 $insideCapsuleFunctionIfTrue : local := false 343 $e : local := $EmptyEnvironment 344 $genSDVar : local := 0 345 $previousTime : local := get_run_time() 346 $s : local := nil 347 $x : local := nil 348 $m : local := nil 349 null(x) => nil 350 $SaveParseOnly => 351 x := walkForm(x) 352 if x then PUSH(x, $globalDefs) 353 $RawParseOnly => PRETTYPRINT(x) 354 $FlatParseOnly => PRETTYPRINT(flattenSemi x) 355 $PostTranOnly => PRETTYPRINT(postTransform x) 356 nform := 357 $noEarlyMacroexpand => x 358 walkForm x 359 null(nform) => nil 360 x := parseTransform(postTransform(nform)) 361 $TranslateOnly => $Translation := x 362 $postStack => 363 displayPreCompilationErrors() 364 userError "precompilation failed" 365 $PrintOnly => 366 FORMAT(true, '"~S =====>~%", $currentLine) 367 PRETTYPRINT(x) 368 u := compTopLevel(x, $EmptyMode, $InteractiveFrame) 369 if u then $InteractiveFrame := THIRD(u) 370 if $semanticErrorStack then displaySemanticErrors() 371 TERPRI() 372