├── 3-lisp.cl ├── 3-lisp.lisp ├── Procedural Reflection in Programming Languages.pdf ├── README.md └── defs.3l /3-lisp.cl: -------------------------------------------------------------------------------- 1 | ;; -*- common-lisp -*- 2 | 3 | ;; Load this with: 4 | ;; (load "3-lisp.cl" :external-format :utf-8) ; LispWorks 5 | ;; (load "3-lisp.cl" :external-format 'charset:utf-8) ; clisp 6 | ;; (load "3-lisp.cl") ; sbcl 7 | ;; so much for portability. 8 | 9 | ;; This is a port of 3-lisp.lisp from CADR-machine LISP (mostly Maclisp) to a 10 | ;; modern Common Lisp. 11 | 12 | ;; Porting notes. 13 | ;; 14 | ;; This 40-years old code required surprisingly few changes. 15 | ;; 16 | ;; Where a difference between Maclisp and Common Lisp is basically a rename, 17 | ;; this rename was done directly in the sources. Specifically: 18 | ;; 19 | ;; Maclisp/CADR Common Lisp 20 | ;; 21 | ;; CASEQ CASE 22 | ;; *CATCH CATCH 23 | ;; *THROW THROW 24 | ;; READCH READ-CHAR 25 | ;; / \ (as an escape) 26 | ;; DECLARE PROCLAIM (at the top level) 27 | ;; COMPILE :COMPILE-TOPLEVEL (EVAL-WHEN keywords, see http://clhs.lisp.se/Body/s_eval_w.htm 28 | ;; LOAD :LOAD-TOPLEVEL "The use of eval, compile, and load is deprecated.") 29 | ;; EVAL :EXECUTE 30 | ;; READTABLE *READTABLE* 31 | ;; LOGIN-SETQ SETQ (https://hanshuebner.github.io/lmman/fd-hac.xml) 32 | ;; IGNORE FOO (DECLARE (IGNORE FOO)) 33 | ;; 34 | 35 | ;; 36 | ;; Some missing Maclisp functions were added: MEMQ, FIXP 37 | ;; 38 | ;; AND is a macro in Common Lisp and cannot be applied. (So much for orthogonality.) See AND*. 39 | ;; 40 | ;; Some functions changed signatures: 41 | ;; 42 | ;; TYPEP Takes 2 parameters and returns Boolean in Common Lisp 43 | ;; BREAK Takes some additional arguments in Maclisp-CADR 44 | ;; IF Like Elisp, Maclisp allows multiple forms in the ELSE part 45 | ;; 46 | ;; 3-NORMALISE* assumes that Common Lisp implementations are tail-recursive, compare 3-lisp.lisp. 47 | ;; 48 | ;; *LEXPR is not needed: 49 | ;; 50 | ;; *lexpr Special Form 51 | ;; 52 | ;; (*lexpr sym1 sym2 ... ) declares sym1, sym2, etc. to 53 | ;; be names of functions. In addition it prevents these functions from 54 | ;; appearing in the list of functions referenced but not defined printed at 55 | ;; the end of the compilation. 56 | ;; 57 | ;; http://www.bitsavers.org/pdf/mit/cadr/chinual_3rdEd_Mar81.pdf 58 | 59 | ;; 60 | ;; Old Lisps had no string type and used symbols for string manipulations. This 61 | ;; weirdly-looking code was preserved to honour human ingenuity, see IMPLODE and 62 | ;; EXPLODEC. 63 | ;; 64 | ;; (https://www.cs.cmu.edu/Groups/AI/html/faqs/lang/lisp/part2/faq-doc-3.html). 65 | ;; 66 | 67 | ;; 68 | ;; 3-lisp re-uses built-in lisp reader to parse 3-lisp input and 3-lisp code 69 | ;; that is part of the 3-lisp implementation. There were some (but again, less 70 | ;; than one would expect for such a sensitive part of the language) changes in 71 | ;; this area: 72 | ;; 73 | ;; READ-PRESERVING-WHITESPACE is used instead of READ in a few places to 74 | ;; avoid eating newlines, see READ*. 75 | ;; 76 | ;; SET-SYNTAX-MACRO-CHAR -> SET-MACRO-CHARACTER. 77 | ;; 78 | ;; "Reader macro function" (the second argument to SET-MACRO-CHARACTER) 79 | ;; takes stream and character. 80 | ;; 81 | ;; There is no SET-SYNTAX-FROM-DESCRIPTION in Common Lisp and there are no 82 | ;; "self-delimiting single-character" symbols (see 83 | ;; http://www.bitsavers.org/pdf/mit/cadr/chinual_5thEd_Jan83/chinualJan83_21_IOsystem.pdf, 84 | ;; p. 381, see CLTL 22.1.1, p. 554), SINGLE-MACRO-CHARACTER. 85 | ;; 86 | ;; Mysteriously, the parser table for this file (L=READTABLE) refers to the 87 | ;; functions defined later in the file (i.e., not yet parsed at the time 88 | ;; when the table is installed). This presumably implies some form of 89 | ;; multi-pass parsing that modern implementations lack and was fixed by 90 | ;; re-ordering the definitions. 91 | ;; 92 | ;; Maclisp maintains backquote context across recursive parser 93 | ;; invocations. For example in the expression (which happens within defun 94 | ;; 3-EXPAND-PAIR) 95 | ;; 96 | ;; `\(PCONS ~,a ~,d) 97 | ;; 98 | ;; the backquote is consumed by the top-level activation of READ. Backslash 99 | ;; forces the switch to 3-lisp readtable and call to 3-READ to handle the 100 | ;; rest of the expression. Within this 3-READ activation, the tilde forces 101 | ;; switch back to L=READTABLE and a call to READ to handle ",a". In Maclisp, 102 | ;; this second READ activation re-uses the backquote context established by 103 | ;; the top-level READ activation. Of all Common Lisp implementations that I 104 | ;; tried, only sbcl correctly handles this situation. Lisp Works and clisp 105 | ;; complain about "comma outside of backquote". In clisp, 106 | ;; clisp-2.49/src/io.d:read_top() explicitly binds BACKQUOTE-LEVEL to nil. 107 | ;; 108 | ;; In addition to UPWARDS ARROW "↑" and LEFTWARDS ARROW "←" used by 3-lisp.lisp, 109 | ;; this file uses DOWNWARDS ARROW "↓" instead of "!". Because progress. 110 | 111 | 112 | ;; 3-lisp implementation from Procedural Reflection in Programming Languages, 113 | ;; volume i., Brian Cantwell Smith, February 1982, Appendix, pp. 708--751. 114 | ;; http://publications.csail.mit.edu/lcs/pubs/pdf/MIT-LCS-TR-272.pdf 115 | 116 | ;;; -*- Mode:LISP; Package:User; Base: 10. -*- Page 1 001 117 | ;;; 002 118 | ;;; 3-LISP 003 119 | ;;; ====== 004 120 | ;;; 005 121 | ;;; A statically scoped, higher order, semantically rationalised, procedurally 006 122 | ;;; reflective dialect of LISP, supporting SIMPLE and REFLECTIVE procedures. 007 123 | ;;; 008 124 | ;;; This is a straightforward and EXTREMELY INEFFICIENT implementation; the 009 125 | ;;; intent is merely to manifest the basic 3-LISP functionality. A variety 010 126 | ;;; of techniques could increase the efficiency by several orders of magnitude 011 127 | ;;; (most obvious would be to avoid consing explicit continuation structures at 012 128 | ;;; each step of NORMALISE). With some ingenuity 3-LISP could be implemented 013 129 | ;;; as efficiently as any other dialect. 014 130 | ;;; 015 131 | ;;; 1. Structural Field: 016 132 | ;;; -------------------- 017 133 | ;;; 018 134 | ;;; Structure Type Designation Notation 019 135 | ;;; 020 136 | ;;; 1. Numerals -- Numbers -- sequence of digits 021 137 | ;;; 2. Booleans -- Truth values -- $T or $F 022 138 | ;;; 3. Pairs -- Functions (& appns) -- ( . ) 023 139 | ;;; 4. Rails -- Sequences -- [ ... ] 024 140 | ;;; 5. Handles -- S-expressions -- ' 025 141 | ;;; 6. Atoms -- (whatever bound to) -- sequence of alphanumerics 026 142 | ;;; 027 143 | ;;; a. There is no derived notion of a LIST, and no atom NIL. 028 144 | ;;; b. Pairs and rails are pseudo-composite; the rest are atomic. 029 145 | ;;; c. Numerals, booleans, and handles are all normal-form and canonical. 030 146 | ;;; Some rails (those whose elements are normal form) and some pairs 031 147 | ;;; (the closures) are normal form, but neither type is canonical. 032 148 | ;;; No atoms are normal-form. 033 149 | ; 034 150 | ;;; 2. Semantics: The semantical domain is typed as follows: 035 151 | ;;; ------------- 036 152 | ;;; ___ numeral 037 153 | ;;; |___ boolean 038 154 | ;;; ____ s-expression ___|___ pair 039 155 | ;;; | |___ rail 040 156 | ;;; | |___ handle 041 157 | ;;; | |___ atom 042 158 | ;;; Object ___| 043 159 | ;;; | ___ number 044 160 | ;;; |____ abstraction ____|___ truth-value 045 161 | ;;; | |___ sequence 046 162 | ;;; | 047 163 | ;;; |_________________________ function 048 164 | ; 049 165 | ;;; 3. Notation 050 166 | ;;; ----------- 051 167 | ;;; 052 168 | ;;; Each structural field category is notated with a distinguishable notational 053 169 | ;;; category, recognisable in the first character, as follows (thus 3-LISP 054 170 | ;;; could be parsed by a grammar with a single-character look-ahead): 055 171 | ;;; 056 172 | ;;; 1. Digit --> Numeral 4. Left bracket --> Rail 057 173 | ;;; 2. Dollar sign --> Boolean 5. Singe quote --> Handle 058 [sic. leg. "Single"] 174 | ;;; 3. Left paren --> Pair 6. Non-digit --> Atom 059 175 | ;;; 060 176 | ;;; The only exceptions are that numerals can have a leading "+" or "-", and in 061 177 | ;;; this implementation an atom may begin with a numeral providing it contains 062 178 | ;;; at least one non-digit (since MACLISP supports that). 063 179 | ;;; Page 1:1 064 180 | ;;; BNF Grammar Double quotes surround object level constants, "←" indicates 065 181 | ;;; ----------- concatenation, brackets delineate groupings, "*" means 066 182 | ;;; zero-or-more repetition, and "|" separates alternatives: 067 183 | ;;; 068 184 | ;;; formula ::= [break←]* form [←break]* 069 185 | ;;; form ::= L-numeral | L-boolean | L-pair | L-rail | L-handle | L-atom 070 186 | ;;; 071 187 | ;;; L-numeral ::= ["+"← | "-"←]* digit [←digit]* 072 188 | ;;; L-boolean ::= "$T" | "$F" 073 189 | ;;; L-pair ::= "("← formula ←"."← formula ←")" 074 190 | ;;; L-rail ::= "["← [formula←]* "]" 075 191 | ;;; L-handle ::= "'"← formula 076 192 | ;;; L-atom ::= [character←]* non-digit [←character]* 077 193 | ;;; 078 194 | ;;; character ::= digit | non-digit 079 195 | ;;; non-digit ::= alphabetic | special 080 196 | ;;; 081 197 | ;;; digit ::= "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" | "0" 082 198 | ;;; alphabetic ::= "a" | "b" | "c" | ... | "A" | "B" | "C" | ... etc. 083 199 | ;;; special ::= "*" | "-" | "+" | "/" | "@" | "#" | "%" | "&" | "<" | ">" | 084 200 | ;;; "←" | "=" | "\" | "?" | ":" | "~" | "↓" 085 201 | ;;; reserved ::= "'" | ";" | "(" | ")" | "[" | "]" | "{" | "}" | "|" | """ | 086 202 | ;;; "," | "." | "↑" | "`" | "$" | | 087 203 | ;;; 088 204 | ;;; break ::= | | comment 089 205 | ;;; comment ::= ";" [←character | ←reserved | ← ]* 090 206 | ;;; 091 207 | ;;; The Lexical Notation Interpretation Function THETA (by category): 092 208 | ;;; ----------------------------------------------------------------- 093 209 | ;;; 094 210 | ;;; L-numeral -- Numerals in the standard fashion; 095 211 | ;;; L-boolean -- $T and $F to each of the two booleans; 096 212 | ;;; L-pair -- A new (otherwise inaccessible) pair whose CAR is THETA of 097 213 | ;;; the first formula and whose CDR is THETA of the second; 098 214 | ;;; L-rail -- A new (otherwise inaccessible) rail whose elements are THETA 099 215 | ;;; of each of the constituent formulae; 100 216 | ;;; L-handle -- The handle of THETA of the constituent formula. 101 [sic. "." vs. ";"] 217 | ;;; L-atom -- The corresponding atom. 102 218 | ;;; 103 219 | ;;; NOTES: 104 220 | ;;; 105 221 | ;;; 1. Case is ignored (converted to upper case on input) 106 222 | ;;; 2. Notational Sugar: 107 223 | ;;; 108 224 | ;;; "( ... )" abbreviates "( . [ ... ])" 109 225 | ;;; 110 226 | ;;; 3. We use exclamation point in place of down-arrow, since MACLISP does 111 227 | ;;; not support the latter character (it is not in ASCII, sadly). 112 228 | ;;; 4. A Summary of the use of reserved characters: 113 229 | ;;; 114 230 | ;;; a: ( -- starts pairs h: . -- in "[ ... ]" for JOIN 115 231 | ;;; b: ) -- ends pairs i: ↑ -- NAME 116 232 | ;;; c: . -- in "( ... )" for CDR j: ↓ -- REFERENT 117 233 | ;;; d: [ -- starts rails (k: : -- DYNAMIC) 118 [DYNAMIC is not present] 234 | ;;; e: ] -- ends rails l: ` -- Backquote a la MACLISP 119 [sic. capitalisation] 235 | ;;; f: ' -- starts handles m: , -- " " " " 120 236 | ;;; g: ; -- starts comments (to CRLF) n: ~ -- Switch to MACLISP 121 237 | ;;; 122 238 | ;;; A-g are primitive, h-m are sugar, and n is implementation-specific. In 123 239 | ;;; this implementation, since "↓" is used for REFERENT (it should be 124 240 | ;;; down-arrow), it is reserved rather than special. Similarly, "~" is 125 241 | ;;; reserved in this implementation for the MACLISP escape. Finally, the 126 242 | ;;; characters "{", "}", "|", and """ are reserved but not currently used 127 243 | ;;; (intended for sacks, arbitrary atom names (a la MACLISP) and strings). 128 244 | ;;; Page 1:2 129 245 | ;;; 4. Processor: 130 246 | ;;; ------------- 131 247 | ;;; 132 248 | ;;; The main driving loop of the processor is a READ-NORMALISE-PRINT loop 133 249 | ;;; (see item 6, below), taking expressions into normal-form co-designators. 134 250 | ;;; The normal form designators for each of the semantic types are: 135 251 | ;;; 136 252 | ;;; Semantic type Normal form designator (NFD) 137 253 | ;;; 138 254 | ;;; 1. Numbers Numerals 139 255 | ;;; 2. Truth-values Boolean constants 140 256 | ;;; 3. S-expressions Handles 141 257 | ;;; 4. Sequences Rails of NFD's of the elements 142 258 | ;;; 5. Functions Pairs: ( ) 143 259 | ;;; 6. Environments Rails: [[' '] [' '] ... ] 144 260 | ;;; 145 261 | ;;; 1-3 are CANONICAL, 4-6 are not. Thus, A = B implies ↑A = ↑B only if A and 146 262 | ;;; B designate numbers, truth-values, or s-expressions. 147 263 | ; 148 264 | ;;; 5. Primitive procedures: 149 265 | ;;; ------------------------ 150 266 | ;;; 151 267 | ;;; Summary (fuller definitions are given below): 152 268 | ;;; 153 269 | ;;; Typing: TYPE -- defined over 10 types (4 syntactic) 154 270 | ;;; Identity: = -- defined over s-expressions, truth- 155 271 | ;;; values, sequences, and numbers 156 272 | ;;; Structural: PCONS, CAR, CDR -- to construct and examine pairs 157 273 | ;;; LENGTH, NTH, TAIL -- to examine rails and sequences 158 274 | ;;; RCONS, SCONS, PREP -- to construct " " " 159 275 | ;;; Modifiers: RPLACA, RPLACD -- to modify pairs 160 276 | ;;; RPLACN, RPLACT -- " " rails 161 277 | ;;; Functions: SIMPLE, REFLECT -- make procedures from expressions 162 278 | ;;; Control: EF -- an extensional if-then-else conditional 163 279 | ;;; Semantics: NAME, REFERENT -- to mediate between sign & signified 164 280 | ;;; Arithmetic: +, -, *, / -- as usual 165 281 | ;;; I/O: READ, PRINT, TERPRI -- as usual 166 282 | ;;; Reflection: LEVEL -- the current reflective level 167 283 | ;;; 168 284 | ;;; The following kernel functions need NOT be primitive; they are defined in 169 285 | ;;; the reflective model in terms of the above: 170 286 | ;;; 171 287 | ;;; DEFINE, LAMBDA, NORMALISE, REDUCE, SET, BINDING, MACRO 172 288 | ;;; 173 289 | ;;; Syntax and definitions: 174 290 | ;;; 175 291 | ;;; Form of use Designation (environment relative): 176 292 | ;;; 177 293 | ;;; (TYPE ) -- The atom indicating the type of (one of 178 294 | ;;; the 10 on the fringe of the tree in #2, above) 179 295 | ;;; 180 296 | ;;; (= ) -- Truth if and are the same, falsity 181 297 | ;;; otherwise, providing and are of the 182 298 | ;;; same type, and are s-expressions, truth-values, 183 299 | ;;; sequences, or numbers 184 300 | ;;; 185 301 | ;;; (PCONS ) -- A (new) pair whose CAR is and CDR is 186 302 | ;;; (CAR ) -- The CAR of pair 187 303 | ;;; (CDR ) -- The CDR of pair 188 304 | ;;; (RPLACA ) -- The new CAR of modified pair 189 305 | ;;; (RPLACD ) -- The new CDR of modified pair 190 306 | ;;; 191 307 | ;;; (LENGTH ) -- The length of rail or sequence 192 308 | ;;; (NTH ) -- The th element of rail or sequence 193 309 | ;;; (TAIL ) -- Tail of rail/seq starting after th elemnt 194 [sic. "elemnt"] 310 | ;;; (RCONS ... ) -- A new rail whose elements are , ... , 195 [sic. comma spacing] 311 | ;;; (SCONS ... ) -- The sequence whose elements are , ..., 196 312 | ;;; (PREP ) -- A new rail/seq whose 1st is , 1st tail is 197 [sic. , leg. ] 313 | ;;; (RPLACN ) -- The new th element of modified rail 198 314 | ;;; (RPLACT ) -- The new th tail of modified rail 199 315 | ;;; Page 1:3 200 316 | ;;; (SIMPLE

) -- NOT FOR CASUAL USE! (The function of given type 201 317 | ;;; (REFLECT

) designated by the lambda abstraction of pattern 202 318 | ;;;

over expression in environment ) 203 319 | ;;; 204 320 | ;;; (EF

) -- , if

designates truth; if falsity. 205 [sic. full stop] 321 | ;;; 206 322 | ;;; (NAME ) -- The (or a) normal-form designator of 207 323 | ;;; (REFERENT ) -- The object designated by in environment 208 324 | ;;; 209 325 | ;;; (+ ) -- The sum, difference, produce, and quotient of 210 [sic. "produce", leg. "product"] 326 | ;;; (- ) and , respectively 211 327 | ;;; (* ) 212 328 | ;;; (/ ) 213 329 | ;;; 214 330 | ;;; (READ) -- The s-expression notated by the next formula in 215 331 | ;;; the input stream. 216 [sic. full stops] 332 | ;;; (PRINT ) -- , which has just been printed. 217 333 | ;;; 218 334 | ;;; (LEVEL) -- The number of the current reflective level. 219 335 | ; 220 336 | ;;; 6. Processor Top Level: 221 337 | ;;; ----------------------- 222 338 | ;;; 223 339 | ;;; Each reflective level of the processor is assumed to start off 224 340 | ;;; running the following function: 225 341 | ;;; 226 342 | ;;; (define READ-NORMALISE-PRINT 227 343 | ;;; (lambda simple [env] 228 344 | ;;; (block (prompt (level)) 229 345 | ;;; (let [[normal-form (normalise (read) env id)]] 230 346 | ;;; (prompt (level)) 231 347 | ;;; (print normal-form) 232 348 | ;;; (read-normalise-print env))))) 233 349 | ;;; 234 350 | ;;; The way this is imagined to work is as follows: the very top processor 235 351 | ;;; level (infinitely high up) is invoked by someone (say, God, or some 236 352 | ;;; functional equivalent) normalising the expression (READ-NORMALISE-PRINT 237 353 | ;;; GLOBAL). When it reads an expression, it is given the input string 238 354 | ;;; "(READ-NORMALISE-PRINT GLOBAL)", which causes the level below it to read 239 355 | ;;; an expression, which is in turn given "(READ-NORMALISE-PRINT GLOBAL)", 240 356 | ;;; and so forth, until finally the second reflective level is given 241 357 | ;;; "(READ-NORMALISE-PRINT GLOBAL)". This types out "1>" on the console, 242 358 | ;;; and awaits YOUR input. 243 359 | ;;; 244 360 | ;;; 7. Environments: 245 361 | ;;; ---------------- 246 362 | ;;; 247 363 | ;;; Environments are sequences of two-element sequences, with each sub-sequence 248 364 | ;;; consisting of a variable and a binding (both of which are of course 249 365 | ;;; expressions). A normal-form environment designator, therefore, is a rail of 250 366 | ;;; rails, with each rail consisting of two handles. Variables are looked up 251 367 | ;;; starting at the front (i.e. the second element of the first subrail whose 252 368 | ;;; first element is the variable is the binding of that variable in that 253 369 | ;;; environment). Environments can also share tails: this is implemented by 254 370 | ;;; normal-form environment designators sharing tails (this is used heavily in 255 371 | ;;; the GLOBAL/ROOT/LOCAL protocols, and so forth). Effecting a side-effect on 256 372 | ;;; the standard normal-form environment designator CHANGES what the environment 257 373 | ;;; is, which is as it should be. Each level is initialised with the same global 258 374 | ;;; environment (the implementation does not support root environments -- see 259 375 | ;;; note 11). Page 1:4 260 376 | ;;; 261 377 | ;;; 8. Implementation: 262 378 | ;;; ------------------ 263 379 | ;;; 264 380 | ;;; 3-LISP Structural Type: MACLISP implementation: 265 381 | ;;; 266 382 | ;;; 1. Numerals -- Numerals 267 383 | ;;; 2. Booleans -- The atoms $T and $F 268 384 | ;;; 3. Pairs -- Pairs 269 385 | ;;; 4. Rails -- (~RAIL~ ... ) (but see note 9) 270 386 | ;;; 5. Handles -- (~QUOTE~ . ) 271 387 | ;;; 6. Atoms -- atoms (except for $T, $F, ~RAIL~, ~QUOTE~, 272 388 | ;;; ~C0~, ~C1~, ~C2~, ~C3~, ~C4~, ~C5~, ~PRIM~, 273 389 | ;;; and NIL) 274 390 | ;;; 275 391 | ;;; The main processor functions constantly construct MACLISP representations 276 392 | ;;; of the 3-LISP normal-form designators of the continuations and environments 277 393 | ;;; that WOULD be being used if the processor were running reflectively. In 278 394 | ;;; this way functions that reflect can be given the right arguments without 279 395 | ;;; further ado. In assembling these continuations and environments (see 280 396 | ;;; 3-NORMALISE etc.), the code assumes that the incoming values are already in 281 397 | ;;; normal form. A more efficient but trickier strategy would be to put these 282 398 | ;;; objects together only if and when they were called for; I haven't attempted 283 399 | ;;; that here. This would all be made simpler if both environments and 284 400 | ;;; continuations were functions abstractly defined: no copying of structure 285 401 | ;;; would ever be needed, since the appropriate behaviour could be wrapped 286 402 | ;;; around the information in whatever form it was encoded in the primitive 287 403 | ;;; implementation. 288 404 | ;;; 289 405 | ;;; Two major recognition strategies are used for efficiency. Those instances 290 406 | ;;; of the four STANDARD continuation types that were generated by the MACLISP 291 407 | ;;; version of the processor are trapped and decoded primitively: if this were 292 408 | ;;; not done the processor would reflect at each step. Also, explicit calls to 293 409 | ;;; REDUCE and NORMALISE are trapped and run directly by the implementing 294 410 | ;;; processor: this is not strictly necessary, but unless it were done the 295 411 | ;;; processor might never come down again after reflecting up. 296 412 | ;;; 297 413 | ;;; The standard continuation types, called C0 - C3, are identified in the 298 414 | ;;; comments and in the definitions of NORMALISE and REDUCE (q.v.), and listed 299 415 | ;;; below. These types must be recognized by 3-APPLY and 3-REDUCE, so that the 300 416 | ;;; implementing processor can drop down whenever possible, whether or not the 301 417 | ;;; explicit interpretation of a (non-primitive) reflective function has 302 418 | ;;; intervened. The atoms ~C0~, ~C1~, ~C2~, and ~C3~ -- called the SIMPLE 303 419 | ;;; ALIASES -- are used instead of the primitive SIMPLE closure as the function 304 420 | ;;; type (i.e. as the CAR of the continuation closures). These atoms are also 305 [sic. triple space] 421 | ;;; MACLISP function names to effect the continuation). The implementation 306 422 | ;;; makes these atoms look = to the SIMPLE closure, so that the user cannot 307 423 | ;;; tell different atoms are being used, but so that the continuations can be 308 424 | ;;; trapped. 309 425 | ;;; 310 426 | ;;; Three other simple aliases are used (~C4~, ~C5~, and ~PRIM~). ~C4~ is used 311 427 | ;;; to identify the continuation used by READ-NORMALISE-PRINT, since the higher 312 428 | ;;; level READ-NORMALISE-PRINT continuation may not explicitly exist. ~C5~ is 313 429 | ;;; used by the IN-3-LISP macro to read in 3-LISP code embedded within MACLISP 314 430 | ;;; (it can therefore be used to read in 3-LISP code in files and so forth). 315 431 | ;;; ~PRIM~ is used in normal-form designators of primitive procedures. Thus, 316 432 | ;;; while PCONS in the initial global environment looks to a 3-LISP program to 317 433 | ;;; normalise to ( '[ ... ] '[A B] '(PCONS A B)), in fact the 318 434 | ;;; CAR of that form is ~PRIM~, not . 319 435 | ;;; 320 436 | ;;; The four standard continuations: 321 437 | ;;; 322 438 | ;;; C0: Accept the normalised function designator in an application. 323 439 | ;;; C1: Accept the normalised arguments for a SIMPLE application. 324 440 | ;;; C2: Accept the normalised first element in a rail fragment. 325 441 | ;;; C3: Accept the normalised tail of a rail fragment. 326 442 | ;;; 327 443 | ;;; (C4: Identifies top level call of READ-NORMALISE-PRINT.) 328 444 | ;;; (C5: Used in order to read in 3-LISP structures by IN-3-LISP.) 329 445 | ;;; Programming conventions: Page 1:5 331 [sic. no 330] 446 | ;;; 332 447 | ;;; Special variables are prefixed with "3=". Procedures are prefixed with "3-". 333 448 | ;;; If they operate on MACLISP structures implementing 3-LISP structures, the 334 449 | ;;; procedure name is defined with respect to the operation viewed with respect 335 450 | ;;; to the 3-LISP structure. For example, 3-EQUAL returns T if the two arguments 336 451 | ;;; encode the same 3-LISP structure. 337 452 | ;;; 338 453 | ;;; NOTE: In fall 1981, the implementation was minimally changed to run on an MIT 339 454 | ;;; CADR machine, not in MACLISP. The only concessions to the new base were in 340 455 | ;;; the treatment of I/O and interrupts; no particular features of the CADR have 341 456 | ;;; been used. It should therefore require minimal work to retrofit it to a 342 457 | ;;; MACLISP base. 343 458 | ; 344 459 | ;;; 9. Rails: Implementation and Management: 345 460 | ;;; ---------------------------------------- 346 461 | ;;; 347 462 | ;;; The implementation of rails is tricky, because RPLACT modifications must be 348 463 | ;;; able to take effect on the 0'th tail, as well as subsequent ones, requiring 349 464 | ;;; either the use of full bi-directional linkages, or "invisible pointers" (a 350 465 | ;;; true LISP-machine implementation could perhaps use the underlying invisible 351 466 | ;;; pointer facility) and special circularity checking. We choose the latter 352 467 | ;;; option. The implementation (where "+" means one or more, "*" means zero or 353 468 | ;;; more) of a rail is: 354 469 | ;;; 355 470 | ;;; [a b ... z] ==> (<~RAIL~>+ a <~RAIL~>* b ... <~RAIL~>* z <~RAIL~>*) 356 471 | ;;; 357 472 | ;;; where the ~RAIL~ atoms are effectively invisible, but begin every rail that 358 473 | ;;; is given out to the outside world (and can thus be used to distinguish 359 474 | ;;; rails from 3-LISP cons pairs). Just reading in [A B ... Z] generates 360 475 | ;;; (~RAIL~ A B ... Z). 361 476 | ;;; 362 477 | ;;; Unless RPLACT's are done, the number of ~RAIL~ atoms cannot exceed the number 363 478 | ;;; of elements. With arbitrary RPLACT'ing, the efficiency can get arbitrarily 364 479 | ;;; bad (although it could be corrected back to a linear constant of 2 by a 365 480 | ;;; compacting garbage collector.) 366 [sic. stop placement] 481 | ;;; 367 482 | ;;; 10. User Interface: 368 483 | ;;; ------------------- 369 484 | ;;; 370 485 | ;;; To run 3-LISP, load the appropriate one of the following FASL files: 371 486 | ;;; 372 487 | ;;; ML: ML:BRIAN;3-LISP FASL 373 [illegible: colon or semicolon?] 488 | ;;; PARC: [Phylum]3-lisp>3-lisp.qfasl 374 489 | ;;; 375 490 | ;;; The processor can be started up by executing (3-LISP), and re-initialised 376 491 | ;;; completely at any point by executing (3-INIT) (both in MACLISP). The 377 492 | ;;; READ-NORMALISE-PRINT loop prints the current reflective level to the left 378 493 | ;;; of the prompt character. The following interrupt characters are defined: 379 494 | ;;; 380 495 | ;;; a. Control-E -- Toggles between MACLISP and 3-LISP. 381 496 | ;;; 382 497 | ;;; b. Control-G -- Quit to level 1 (regular quit in MACLISP) 383 [sic. full stop] 498 | ;;; c. Control-F -- Quit to current level (regular quit in MACLISP) 384 499 | ;;; 385 500 | ;;; To read in and manipulate files, surround an arbitrary number of 386 501 | ;;; expressions with the MACLISP wrapping macro IN-3-LISP, and precede each 387 502 | ;;; 3-LISP expression with a backslash, so that it will be read in by the 388 503 | ;;; 3-LISP reader. Then load the file as if it were a regular MACLISP file. 389 504 | ;;; For example: 390 505 | ;;; 391 506 | ;;; (in-3-lisp 392 507 | ;;; \(define increment (lambda simple [x] (+ x 1))) 393 508 | ;;; \(define quit (lambda reflect [] 'QUIT))) 394 509 | ;;; 395 510 | ;;; Equivalent, and with the advantage that TAGS and @ see the definitions, is: 396 511 | ;;; 397 512 | ;;; (in-3-lisp \[ 398 513 | ;;; 399 514 | ;;; (define increment (lambda simple [x] (+ x 1))) 400 515 | ;;; (define quit (lambda reflect ? 'QUIT)) ]) 401 516 | ;;; Page 1:6 404 [sic. no 402, 403] 517 | ;;; 11. Limitations of the Implementation: 405 518 | ;;; -------------------------------------- 406 519 | ;;; 407 520 | ;;; There are a variety of respects in which this implementation is incomplete 408 521 | ;;; or flawed: 409 522 | ;;; 410 523 | ;;; 1. Side effects to the reflective procedures will not be noticed -- in a 411 524 | ;;; serious implementation these procedures would want to be kept in a pure 412 525 | ;;; page so that side effects to them could be trapped, causing one level 413 526 | ;;; of reflective deferral. 414 527 | ;;; 415 528 | ;;; 2. Reflective deferral is not yet support at all. No problems are 416 [sic. leg. "supported"] 529 | ;;; expected; it merely needs attention. 417 530 | ;;; 418 531 | ;;; 3. In part because I think it may be a bad idea, this implementation does 419 532 | ;;; not support a root environment protocol. 420 533 | ;;; 421 534 | ;;; 12. Obvious Extensions: 422 535 | ;;; ----------------------- 423 536 | ;;; 424 537 | ;;; Obvious extensions to the implementation fall into two groups: those that 425 538 | ;;; would increase the efficiency of the implementation, but not change its 426 539 | ;;; basic functionality, and those that would extend that functionality. 427 540 | ;;; Regarding the first, the following are obvious candidates: 428 541 | ;;; 429 542 | ;;; 1. Get rid of the automatic consing of continuation and environment 430 543 | ;;; structures, as mentioned earlier. 431 544 | ;;; 432 545 | ;;; 2. Support various intensional procedures (LAMBDA, IF, COND, MACRO, SELECT, 433 546 | ;;; and so forth) as primitives. This would require the virtual provision 434 547 | ;;; of all of the continuation structure at the reflective level that would 435 548 | ;;; have been generated had the definitions used here been used explicitly: 436 549 | ;;; it wouldn't be trivial. Unless, of course, the language was redefined 437 550 | ;;; to include these as primitives (but the current proof of its finiteness 438 551 | ;;; depends on no reflective primitives, so this too would take some work). 439 552 | ;;; 440 553 | ;;; Functional extensions include: 441 554 | ;;; 442 555 | ;;; 1. Make the bodies of LAMDBA, LET, COND, etc. take multiple expressions 443 [sic. "LAMDBA"] 556 | ;;; (i.e. be virtual BLOCK bodies). 444 557 | ;;; 445 558 | ;;; 2. Strings (and normal-form string designators, perhaps called "STRINGERS") 446 559 | ;;; could be added. 447 560 | ; 448 561 | #+sbcl (declaim (sb-ext:muffle-conditions style-warning)) 562 | 563 | ;;; Page 2 001 564 | ;;; Declarations and Macros: 002 565 | ;;; ======================== 003 566 | ; 004 567 | (proclaim ; 005 568 | '(special ; 006 569 | 3=simple-aliases 3=global-environment 3=states 3=level 3=break-flag ; 007 570 | 3=in-use 3=readtable L=readtable S=readtable 3=a1 3=a2 3=a3 3=a4 ; 008 571 | 3=normalise-closure 3=reduce-closure 3=simple-closure 3=reflect-closure ; 009 572 | 3=id-closure 3=backquote-depth)) ; 010 573 | ;(proclaim '(ignore 3=process)) 574 | 575 | ;;; (herald 3-LISP) 013 576 | ; 014 577 | (eval-when (:load-toplevel :execute :compile-toplevel) ; 015 578 | ; 016 579 | ;; Common Lisp portability 580 | (defun memq (x y) (member x y :test #'eq)) 581 | 582 | (defun explodec (object) 583 | (loop for char across (prin1-to-string object) 584 | collect (intern (string char)))) 585 | 586 | (defun implode (list) 587 | (read-from-string (coerce (mapcar #'character list) 'string))) 588 | 589 | (defun fixp (x) (integerp x)) 590 | 591 | (defun and* (&rest args) 592 | (cond ((null args) t) 593 | ((car args) (apply #'and* (cdr args))) 594 | (nil))) 595 | 596 | (defmacro list? (x) `(typep ,x 'list)) ; 017 597 | (defmacro 1st (l) `(car ,l)) ; 018 598 | (defmacro 2nd (l) `(cadr ,l)) ; 019 599 | (defmacro 3rd (l) `(caddr ,l)) ; 020 600 | ; 021 601 | ) ; 022 602 | ; 023 603 | (defmacro 3-primitive-simple-id (proc) `(cadr (3r-3rd (cdr ,proc)))) ; 024 604 | ; 025 605 | (defmacro 3-numeral (e) `(fixp ,e)) ; 026 606 | (defmacro 3-boolean (e) `(member ,e '($T $F))) ; 027 607 | ; 028 608 | (defmacro 3-bind (vars vals env) ; 029 609 | `(cons '~RAIL~ (nconc (3-bind* ,vars ,vals) ,env))) ; 030 610 | ; 031 611 | ;;; Two macros having to do with input: 032 612 | ; 033 613 | (defmacro in-3-lisp (&rest body) ; 034 614 | `(progn (or (boundp '3=global-environment) (3-init)) ; 035 615 | ,@(do ((exprs body (cdr exprs)) ; 036 616 | (forms nil (cons `(3-lispify ',(car exprs)) forms))) ; 037 617 | ((null exprs) (nreverse forms))))) ; 038 618 | ; 039 619 | (defmacro ~3-BACKQUOTE (expr) (3-expand expr nil)) ; 040 620 | ; 041 621 | ;;; 3-NORMALISE* If MACLISP were tail-recursive, calls to this would 042 622 | ;;; ------------ simply call 3-NORMALISE. Sets up the loop variables 043 623 | ;;; and jumps to the top of the driving loop. 044 624 | ; 045 625 | (defun 3-normalise* (exp env cont) ; 046 626 | (3-normalise exp env cont)) 627 | ; 049 628 | ;;; The rest of the macro definitions are RAIL specific: 050 629 | ; 051 630 | (defmacro 3r-1st (exp) `(car (3-strip ,exp))) ; 052 631 | (defmacro 3r-2nd (exp) `(car (3-strip (3-strip ,exp)))) ; 053 632 | (defmacro 3r-3rd (exp) `(car (3-strip (3-strip (3-strip ,exp))))) ; 054 633 | (defmacro 3r-4th (exp) `(car (3-strip (3-strip (3-strip (3-strip ,exp)))))) ; 055 634 | ; 056 635 | ;;; Macros for RAIL management: 057 636 | ; 058 637 | ;;; 3-STRIP -- Returns a rail with all ~RAIL~ headers removed. Have 059 638 | ;;; ------- have to step through as many headers as have built up. 060 [sic. "have"] 639 | ;;; 061 640 | ;;; 3-STRIP* -- Returns the last header of arg -- used for RPLACD, and 062 641 | ;;; -------- to establish rail identity. Steps down through headers. 063 642 | ; 064 643 | (eval-when (:load-toplevel :execute :compile-toplevel) ; 065 644 | ; 066 645 | (defmacro 3-strip (rail) ; 067 646 | `(do ((rest (cdr ,rail) (cdr rest))) ; 068 647 | ((not (eq (car rest) '~RAIL~)) rest))) ; 069 648 | ; Page 2:1 070 649 | (defmacro 3-strip* (rail) ; 071 650 | `(do ((rest ,rail (cdr rest))) ; 072 651 | ((not (eq (cadr rest) '~RAIL~)) rest))) ; 073 652 | ; 074 653 | ) ; 075 654 | ; 076 655 | ;;; 3-LENGTH* -- Return the length of a 3-LISP rail. 077 [sic. "return" vs. "returns"] 656 | ; 078 657 | (defmacro 3-length* (rail) ; 079 658 | `(do ((n 0 (1+ n)) ; 080 659 | (rail (3-strip ,rail) (3-strip rail))) ; 081 660 | ((null rail) n))) ; 082 661 | ; 083 662 | ; Page 3 001 663 | ;;; Input/Output: 002 664 | ;;; ============= 003 665 | ;;; 004 666 | ; 005 667 | ;;; A special readtable (3=READTABLE) is used to read in 3-LISP notation, since 006 668 | ;;; it must be parsed differently from MACLISP notation. The 3-LISP READ- 007 669 | ;;; NORMALISE-PRINT loop uses this; in addition, a single expression will be 008 670 | ;;; read in under the 3-LISP reader if preceded by backslash ("\") in the 009 671 | ;;; MACLISP reader. Similarly, a single expression will be read in by the 010 672 | ;;; MACLISP reader if preceded with a tilde ("~") in the 3-LISP reader. 011 673 | ;;; 012 674 | ;;; MACLISP and 3-LISP both support backquote. The readers and the backquotes 013 675 | ;;; can be mixed, but be cautious: the evaluated or normalised expression must 014 676 | ;;; be read in with the right reader. For example, a MACLISP backquoted 015 677 | ;;; expression can contain a 3-LISP fragment with a to-be-evaluated-by-MACLISP 016 678 | ;;; constituent, but a tilde is required before it, so that the MACLISP reader 017 679 | ;;; will see it. Example: "`\[value ~,(plus x y)]". ",@" and ",." are not 018 680 | ;;; supported by the 3-LISP backquote. 019 681 | ;;; 020 682 | ;;; Any 3-LISP backquoted expression will expand to a new-structure-creating 021 683 | ;;; expression at the level of the back-quote, down to and including any level 022 [sic. hyphenation] 684 | ;;; including a comma'ed expression. Thus `[] expands to (rcons), `[[a b c] [d 023 685 | ;;; ,e f]] expands to (rcons '[a b c] (rcons 'd e 'f)), and so forth. This is 024 686 | ;;; done so as to minimise the chance of unwanted shared tails, but to avoid 025 687 | ;;; unnecessary structure consing. We use `[] in place of (rcons) many times in 026 688 | ;;; the code. 027 689 | ;;; 028 690 | ;;; Expressions like "~~C0~" are necessary in order to get the aliases into 029 691 | ;;; 3-LISP, since the first tilde flips readers. Once 3-LISP has been 030 692 | ;;; initialised the aliases will be rejected: to reload a function containing an 031 693 | ;;; alias, temporarily bind 3=simple-aliases to NIL. 032 694 | ;;; 033 695 | ;;; There are two special read macro characters, for name and referent (MACLISP 034 696 | ;;; and 3-LISP versions). (Ideally these would be uparrow and downarrow, but 035 697 | ;;; down-arrow is unfortunately not an ASCII character): 036 [sic. hyphenation] 698 | ;;; 037 699 | ;;; Form MACLISP expansion 3-LISP expansion 038 700 | ;;; 039 701 | ;;; 1. ↑ (3-NAME ) (NAME ) 040 702 | ;;; 2. ↓ (3-REF ) (REFERENT (current-env)) 041 703 | ; 042 704 | 705 | (eval-when (:load-toplevel :execute :compile-toplevel) ; 043 706 | ; 044 707 | ;;; Five constants need to be defined for 3-LISP structures to be read in: 045 708 | ; 046 709 | 710 | (setq S=readtable *readtable* ; Save the system readtable ; 047 711 | L=readtable (copy-readtable) ; and name two special ones: ; 048 712 | 3=readtable (copy-readtable) ; one for LISP, one for 3-LISP. ; 049 713 | 3=simple-aliases nil ; Make these NIL so we can read ; 050 714 | 3=backquote-depth 0) ; in the aliases in this file! ; 051 715 | ; 052 716 | ;;; The following has been modified from the original MACLISP to enable it to 053 717 | ;;; operate under the I/O protocols of the MIT LISP machine: 054 718 | ; 055 719 | (setq *readtable* L=readtable) ; Needed in order to read this file. ; 056 720 | ; 057 721 | (defun single-macro-character (stream char) 722 | (declare (ignore stream)) 723 | (intern (string char))) 724 | 725 | (defun read* (s) 726 | (read-preserving-whitespace s)) 727 | 728 | (let ((*readtable* L=readtable)) ; 058 729 | (set-macro-character #\\ #'(lambda (s c) (3-read s))) ; 059 730 | (set-macro-character #\↑ #'(lambda (s c) `(cons '~QUOTE~ ,(read* s)))) ; 060 731 | (set-macro-character #\↓ #'(lambda (s c) `(3-ref ,(read* s)))) ; 061 732 | (set-macro-character #\] #'single-macro-character)) ; So "~FOO]" will work. ; 062 733 | ; Page 3:1 ; [sic. no line number] 734 | ; 063 735 | (let ((*readtable* 3=readtable)) ; 064 736 | (set-macro-character #\~ #'(lambda (s c) (let ((*readtable* L=readtable)) (read* s)))) ; 065 737 | (set-macro-character #\↓ #'(lambda (s c) `(referent ~RAIL~ ,(3-read* s) ; 066 738 | (current-env ~RAIL~)))) ; 067 739 | (set-macro-character #\↑ #'(lambda (s c) `(name ~RAIL~ ,(3-read* s)))) ; 068 740 | (set-macro-character #\' #'(lambda (s c) `(~QUOTE~ . ,(3-read* s)))) ; 069 741 | (set-macro-character #\( #'(lambda (s c) (3-read-pair s))) ; 070 742 | (set-macro-character #\[ #'(lambda (s c) (3-read-rail s))) ; 071 743 | (set-macro-character #\` #'(lambda (s c) (3-backq-macro s))) ; 072 744 | (set-macro-character #\, #'(lambda (s c) (3-comma-macro s))) ; 073 745 | (set-macro-character #\) #'single-macro-character) ; 074 746 | (set-macro-character #\/ #'single-macro-character) ; 075 747 | (set-macro-character #\$ #'single-macro-character) ; 076 748 | (set-macro-character #\] #'single-macro-character) ; 077 749 | (set-macro-character #\. #'single-macro-character)) ; 078 750 | ; 079 751 | ;;; 3-ERROR General error handler. MESSAGE is to be printed by MACLISP's 005 752 | ;;; ------- PRINC, whereas EXPR is printed by 3-PRINT. 006 753 | ; 007 754 | (defun 3-error (message &optional expr (label '|ERROR: |)) ; 008 755 | (terpri) ; 009 756 | (princ label) ; 010 757 | (if (atom message) ; 011 758 | (princ message) ; 012 759 | (mapc #'(lambda (el) (princ el) (princ '| |)) ; 013 760 | message)) ; 014 761 | (if expr (3-print expr)) ; 015 762 | (break) ; 016 763 | (if 3=in-use ; 017 764 | (throw '3-level-loop nil) ; 018 765 | (3-lisp))) ; 019 766 | ; 020 767 | 768 | ;;; 3-TYPE-ERROR 3-ILLEGAL-CHAR 021 769 | ;;; 3-INDEX-ERROR 3-ILLEGAL-ATOM 022 770 | ;;; 3-IMPLEMENTATION-ERROR 3-ILLEGAL-BOOLEAN 023 771 | ;;; ---------------------- ----------------- 024 772 | ; 025 773 | (defun 3-type-error (exp type) ; 026 774 | (3-error `(expected a ,(implode `(,@(explodec type) #\,)) ; 027 775 | but found the ,(3-type exp)) ; 028 776 | exp '|TYPE-ERROR: |)) ; 029 777 | ; 030 778 | (defun 3-ref-type-error (exp type) ; 031 779 | (3-error `(expected a ,(implode `(,@(explodec type) #\,)) ; 032 780 | but found the ,(3-ref-type exp)) ; 033 781 | exp '|TYPE-ERROR: |)) ; 034 782 | ; 035 783 | (defun 3-index-error (n rail) ; 036 784 | (3-error `(,n is out of range for) rail '|INDEX-ERROR: |)) ; 037 785 | ; 038 786 | (defun 3-implementation-error () (3-error '|Illegal implementation state!|)) ; 039 787 | ; 040 788 | (defun 3-illegal-char (char) ; 041 789 | (3-error `(unexpected ,(implode `(|"| ,@(explodec char) |"|))) ; 042 790 | nil '|NOTATION-ERROR: |)) ; 043 791 | ; 044 792 | (defun 3-illegal-boolean (exp) ; 045 793 | (3-error `(expected a boolean\, but found ,(implode `($ ,@(explodec exp)))) ; 046 794 | nil '|NOTATION-ERROR: |)) ; 047 795 | ; 048 796 | (defun 3-illegal-atom (atom) ; 049 797 | (3-error `(The atom ,atom is reserved in this implementation) ; 050 798 | nil '|STRUCTURE-ERROR: |)) ; 051 799 | ; 052 800 | 801 | ;;; 3-READ(*) Read in one 3-LISP s-expression (*-version assumes the 080 802 | ;;; --------- 3-LISP readtable is already in force, and accepts an 081 803 | ;;; optional list of otherwise illegal atoms to let through). 082 804 | ; 083 805 | (defun 3-read (&optional stream) ; 084 806 | (let ((*readtable* 3=readtable)) (3-read* stream))) ; 085 807 | ; 086 808 | (defun 3-read* (stream &optional OK) ; 087 809 | (let ((token (read* stream))) ; 088 810 | (cond ((memq token OK) token) ; 089 811 | ((memq token '(|)| |.| |]|)) (3-illegal-char token)) ; 090 812 | ((or (memq token '(~RAIL~ ~QUOTE~ NIL)) ; 091 813 | (memq token 3=simple-aliases)) (3-illegal-atom token)) ; 092 814 | ((eq token '\$) (3-read-boolean stream)) ; 093 815 | (t token)))) ; 094 816 | ; 095 817 | (defun 3-read-boolean (stream) ; 096 818 | (let ((a (read-char stream))) ; 097 819 | (cond ((memq a '(#\T #\t)) '$T) ; 098 820 | ((memq a '(#\F #\f)) '$F) ; 099 821 | (t (3-illegal-boolean a))))) ; 100 822 | ; 101 823 | (defun 3-read-pair (stream) ; 102 824 | (let ((a (3-read* stream)) ; 103 825 | (b (3-read* stream '(|.| |)|)))) ; 104 826 | (if (eq b '|.|) ; 105 827 | (prog1 (cons a (3-read* stream)) ; 106 828 | (setq b (read* stream)) ; 107 829 | (if (not (eq b '|)|)) (3-illegal-char b))) ; 108 830 | (do ((b b (3-read* stream '(|)|))) ; 109 831 | (c nil (cons b c))) ; 110 832 | ((eq b '|)|) (list* a '~RAIL~ (nreverse c))))))) ; 111 833 | ; 112 834 | (defun 3-read-rail (stream) ; 113 835 | (do ((a nil (cons b a)) ; 114 836 | (b (3-read* stream '(|]|)) (3-read* stream '(|]|)))) ; 115 837 | ((eq b '|]|) (cons '~RAIL~ (nreverse a))))) ; 116 838 | ; 117 839 | ) ; End of eval-when ; 118 840 | ; Page 3:2 ; [sic. no line number] 841 | (eval-when (:execute :load-toplevel :compile-toplevel) 842 | ; Start another eval-when, since the following ; 119 843 | ; needs to be read in using 3-READ ; 120 844 | ; 121 845 | (defun 3-type (exp) ; 007 846 | (cond ((fixp exp) 'numeral) ; 008 847 | ((memq exp '($T $F)) 'boolean) ; 009 848 | ((symbolp exp) 'atom) ; 010 849 | ((eq (car exp) '~RAIL~) 'rail) ; 011 850 | ((eq (car exp) '~QUOTE~) 'handle) ; 012 851 | (t 'pair))) ; 013 852 | 853 | ;;; BACKQUOTE 3-BACKQ-MACRO and 3-COMMA-MACRO are run on reading: they 122 854 | ;;; --------- put calls to ~3-BACKQUOTE and ~3-COMMA into the structures 123 855 | ;;; they build, which are then run on exit. This allows the 124 856 | ;;; expansion to happen from the inside out. 125 857 | ; 126 858 | (defun 3-backq-macro (stream) ; 127 859 | (let ((3=backquote-depth (1+ 3=backquote-depth))) ; 128 860 | (macroexpand (list '~3-BACKQUOTE (read* stream))))) ; 129 861 | ; 130 862 | (defun 3-comma-macro (stream) ; 131 863 | (if (< 3=backquote-depth 1) (3-error '|Unscoped comma|)) ; 132 864 | (let ((3=backquote-depth (1- 3=backquote-depth))) ; 133 865 | (cons '~3-COMMA (read* stream)))) ; 134 866 | ; 135 867 | ;;; The second argument to the next 3 procedures is a flag: NIL if the 136 868 | ;;; backquote was at this level; T if not (implying that coalescing can 137 869 | ;;; happen if possible). 138 870 | ; 139 871 | (defun 3-expand (x f) ; 140 872 | (case (3-type x) ; 141 873 | (PAIR (3-expand-pair x f)) ; 142 874 | (RAIL (3-expand-rail x f)) ; 143 875 | (T ↑x))) ; 144 876 | ; 145 877 | (defun 3-expand-pair (x f) ; 146 878 | (cond ((eq (car x) '~3-COMMA) (cdr x)) ; Found a ",". ; 147 879 | ((eq (car x) '~3-BACKQUOTE) ; Recursive use of backq, so ; 148 880 | (3-expand (macroexpand x) f)) ; expand the inner one and then ; 149 881 | (t (let ((a (3-expand (car x) t)) ; this one. ; 150 882 | (d (3-expand (cdr x) t))) ; 151 883 | (if (and f (3-handle a) (3-handle d)) ; 152 884 | ↑(cons (cdr a) (cdr d)) ; Do the cons now if possible; ; 153 885 | `\(PCONS ~,a ~,d)))))) ; else use MACLISP's backquote ; 154 886 | ; to form a call to PCONS. ; 155 887 | ; 156 888 | (defun 3-expand-rail (rail f) ; 157 889 | (do ((rail (3-strip rail) (3-strip rail)) ; 158 890 | (elements nil (cons (3-expand (car rail) t) elements))) ; 159 891 | ((null rail) ; 160 892 | (if (and f (apply 'and* (mapcar '3-handle elements))) ; 161 893 | ↑(cons '~RAIL~ (mapcar 'cdr (nreverse elements))) ; 162 894 | `(RCONS ~RAIL~ ,@(nreverse elements)))))) ; 163 895 | ; 164 896 | ) ; end of eval-when ; 165 897 | ; Page 3:3 ; [sic. no line number] 898 | ; 166 899 | ;;; 3-PRINT Print out in 3-LISP notation using notational sugar if 167 900 | ;;; ------- possible. No preliminary CR is printed (use TERPRI). Some 168 901 | ;;; attempt is made to avoid printing known circular structures 169 902 | ;;; (like and and obvious circular environments 170 903 | ;;; of a sort that would be generated by Z). 171 904 | ; 172 905 | (defun 3-print (exp) ; 173 906 | (case (3-type exp) ; 174 907 | (numeral (princ exp)) ; 175 908 | (boolean (princ exp)) ; 176 909 | (atom (if (memq exp 3=simple-aliases) ; 177 910 | (princ ') ; 178 911 | (prin1 exp))) ; 179 912 | (handle (princ '|'|) (3-print ↓exp)) ; 180 913 | (pair (cond ((eq exp 3=simple-closure) (princ ')) ; 181 914 | ((eq exp 3=reflect-closure) (princ ')) ; 182 915 | (t (princ '|(|) ; 183 916 | (3-print (car exp)) ; 184 917 | (if (3-rail (cdr exp)) ; 185 918 | (if (3-circular-closure-p exp) ; 186 919 | (progn (princ '| |) ; 187 920 | (3-print-elements (cddr exp) 't)) ; 188 921 | (3-print-elements (cdr exp) 't)) ; 189 922 | (progn (princ '| . |) (3-print (cdr exp)))) ; 190 923 | (princ '|)|)))) ; 191 924 | (rail (princ '|[|) ; 192 925 | (3-print-elements exp 'nil) ; 193 926 | (princ '|]|)))) ; 194 927 | ; 195 928 | (defun 3-print-elements (list flag) ; 196 929 | (let ((global (3-strip 3=global-environment))) ; 197 930 | (do ((list (3-strip list) (3-strip list)) ; 198 931 | (flag flag 't)) ; 199 932 | ((null list)) ; 200 933 | (if (eq list global) ; 201 934 | (return (princ '| ... |))) ; 202 935 | (if flag (princ '| |)) ; 203 936 | (3-print (car list))))) ; 204 937 | ; 205 938 | (defun 3-prompt (level &optional (char ">")) ; 206 939 | (format t "~%~D~A " level char) ; 207 940 | (finish-output)) 941 | ; 210 942 | (defun 3-circular-closure-p (exp) ; 211 943 | (and (< 0 (3-length (cdr exp))) ; 212 944 | (3-rail (3r-1st (cdr exp))) ; 213 945 | (< 0 (3-length (3r-1st (cdr exp)))) ; 214 946 | (let ((env? (3r-1st (3r-1st (cdr exp))))) ; 215 947 | (and (3-rail env?) ; 216 948 | (< 1 (3-length env?)) ; 217 949 | (3-handle (3r-1st env?)) ; 218 950 | (3-atom ↓(3r-1st env?)) ; 219 951 | (3-handle (3r-2nd env?)) ; 220 952 | (eq exp ↓(3r-2nd env?)))))) ; 221 953 | ; 222 954 | ; Page 4 ; [sic. no line number] 955 | ; 001 956 | ;;; Main Processor: 002 957 | ;;; =============== 003 958 | ;;; 004 959 | ;;; 005 960 | ;;; 3-NORMALISE and 3-REDUCE The second clause in the following takes care 006 961 | ;;; ------------------------ of numerals, booleans, handles, normal-form 007 962 | ;;; function designators (applications in terms of 008 963 | ;;; the functions SIMPLE, MACRO, and REFLECT whose args are in normal form), 009 964 | ;;; and normal-form sequence designators (rails whose elements are all in 010 965 | ;;; normal-form). Thus all normal-form expressions normalise to themselves, 011 966 | ;;; even those (like rails and function-designators) that are not canonical 012 967 | ;;; designators of their referents. 013 968 | ; 014 969 | (defun 3-normalise (exp env cont) ; 015 970 | (cond ((3-atom exp) (3-apply cont (3-binding exp env))) ; 016 971 | ((3-normal exp) (3-apply cont exp)) ; 017 972 | ((3-rail exp) (3-normalise-rail exp env cont)) ; 018 973 | (t (3-reduce (car exp) (cdr exp) env cont)))) ; 019 974 | ; 020 975 | (defun 3-reduce (proc args env cont) ; 021 976 | (3-normalise* proc env ; 022 977 | `\(~~C0~ [['proc ~,↑proc] ['args ~,↑args] ['env ~,↑env] ['cont ~,↑cont]] ; C0 ; 023 978 | '[proc*] ; 024 979 | '(selectq (procedure-type proc*) ; 025 980 | [reflect ((simple . ↓(cdr proc*)) args env cont)] ; 026 981 | [simple (normalise args env (make-c1 proc* cont))])))) ; 027 982 | ; 028 983 | ;;; 3-NORMALISE-RAIL Normalise (the first element of) a rail. 029 984 | ;;; ---------------- 030 985 | ; 031 986 | (defun 3-normalise-rail (rail env cont) ; 032 987 | (if (null (3-strip rail)) ; 033 988 | (3-apply cont rail) ; 034 989 | (3-normalise* (3r-1st rail) env ; 035 990 | `\(~~C2~ [['rail ~,↑rail] ['env ~,↑env] ['cont ~,↑cont]] ; C2 ; 036 991 | '[element*] ; 037 992 | '(normalise-rail (rest rail) env ; 038 993 | (lambda simple [rest*] ; 039 994 | (cont (prep element* rest*)))))))) ; 040 995 | ; 041 996 | ;;; 3-PRIMITIVE-REDUCE-SIMPLE The way each primitive function is treated is 042 997 | ;;; ------------------------- highly dependent on the way that 3-LISP 043 998 | ;;; structures are encoded in MACLISP. 044 999 | ; 045 1000 | (defun 3-primitive-reduce-simple (proc args cont) ; 046 1001 | (3-rail-check args) ; 047 1002 | (if (eq proc 'referent) ; 048 1003 | (3-normalise* ↓(3r-1st args) (3r-2nd args) cont) ; 049 1004 | (3-apply cont ; 050 1005 | (case proc ; 051 1006 | (simple `(,3=simple-closure . ,args)) ; 052 1007 | (reflect `(,3=reflect-closure . ,args)) ; 053 1008 | (type ↑(3-ref-type (3r-1st args))) ; 054 1009 | (ef (if (eq (3-bool-check (3r-1st args)) '$T) ; 055 1010 | (3r-2nd args) (3r-3rd args))) ; [sic. no line number] 1011 | (pcons ↑(cons ↓(3r-1st args) ↓(3r-2nd args))) ; 056 1012 | (car ↑(car (3-pair-check ↓(3r-1st args)))) ; 057 1013 | (cdr ↑(cdr (3-pair-check ↓(3r-1st args)))) ; 058 1014 | (length (3-length (3r-1st args))) ; 059 1015 | (nth (3-nth (3r-1st args) (3r-2nd args))) ; 060 1016 | (tail (3-tail (3r-1st args) (3r-2nd args))) ; 061 1017 | (prep (3-prep (3r-1st args) (3r-2nd args))) ; 062 1018 | (rcons (3-rcons (3-rail-check args))) ; 063 1019 | (scons (3-scons (3-rail-check args))) ; 064 1020 | (rplaca ↑(rplaca (3-pair-check ↓(3r-1st args)) ↓(3r-2nd args))) ; 065 1021 | (rplacd ↑(rplacd (3-pair-check ↓(3r-1st args)) ↓(3r-2nd args))) ; 066 1022 | (rplacn ↑(3-rplacn (3r-1st args) ↓(3r-2nd args) ↓(3r-3rd args))) ; 067 1023 | (rplact ↑(3-rplact (3r-1st args) ↓(3r-2nd args) ↓(3r-3rd args))) ; 068 1024 | ; Page 4:1 ; [sic. no line number] 1025 | (= (if (3-equal (3r-1st args) (3r-2nd args)) '$T '$F)) ; 069 1026 | (read ↑(3-read)) ; 070 1027 | (print (3-print ↓(3r-1st args)) (princ #\ ) '$T) ; 071 1028 | (terpri (terpri) '$T) ; 072 1029 | (+ (+ (3-num-check (3r-1st args)) (3-num-check (3r-2nd args)))) ; 073 1030 | (* (* (3-num-check (3r-1st args)) (3-num-check (3r-2nd args)))) ; 074 1031 | (- (- (3-num-check (3r-1st args)) (3-num-check (3r-2nd args)))) ; 075 1032 | (/ (/ (3-num-check (3r-1st args)) (3-num-check (3r-2nd args)))) ; 076 1033 | (name ↑(3r-1st args)) ; 077 1034 | (*rebind (3-rebind ↓(3r-1st args) (3r-2nd args) (3r-3rd args))) ; for ; 078 1035 | (level 3=level) ; efficiency ; 079 1036 | (t (3-implementation-error)))))) ; 080 1037 | ; Page 5 ; 001 1038 | ;;; Continuation Application: 002 1039 | ;;; ========================= 003 1040 | ;;; 004 1041 | ;;; 3-APPLY Called with 3-LISP continuations, has to sort them out and do 005 1042 | ;;; ------- the right non-reflected thing with those that are tokens of the 006 1043 | ;;; six types (C0 - C5) that are primitively recognized. In 007 1044 | ;;; addition, redexes in terms of primitive procedures (identified by PRIM) 008 1045 | ;;; are recognised. We assume a continuation of the form 009 1046 | ;;; ( . [env [arg] body]), and a standard environment structure. 010 1047 | ; 011 1048 | (defmacro 3a-env (cont) `(3r-1st (cdr ,cont))) ; 012 1049 | (defmacro 3a-arg (cont) `(3r-2nd (cdr ,cont))) ; 013 1050 | (defmacro 3a-1st (env) `↓(3r-2nd (3r-1st ,env))) ; 014 1051 | (defmacro 3a-2nd (env) `↓(3r-2nd (3r-2nd ,env))) ; 015 1052 | (defmacro 3a-3rd (env) `↓(3r-2nd (3r-3rd ,env))) ; 016 1053 | (defmacro 3a-4th (env) `↓(3r-2nd (3r-4th ,env))) ; 017 1054 | ; 018 1055 | (defun 3-apply (cont normal-form) ; 019 1056 | (let ((env (3a-env cont))) ; 020 1057 | (if (memq (car cont) 3=simple-aliases) ; 021 1058 | (funcall (car cont) env cont normal-form) ; 022 1059 | (let ((new-level (3-increment-level))) ; REFLECT UP! ; 023 1060 | (3-reduce cont ↑`\[~,normal-form] ; =========== ; 024 1061 | (car new-level) (cdr new-level)))))) ; 025 1062 | ; 026 1063 | ;;; C0: Accept a normalised function designator from a pair. Dispatch 027 1064 | ;;; --- on the function type: if it is SIMPLE, normalise the args; if 028 1065 | ;;; primitive reflective, go do it; otherwise reflect up explicitly. 029 1066 | ; 030 1067 | (defun ~C0~ (env cont proc) ; 031 1068 | (declare (ignore cont)) ; 032 1069 | (let ((args (3a-2nd env)) ; 033 1070 | (env (3a-3rd env)) ; 034 1071 | (cont (3a-4th env))) ; 035 1072 | (case (3-proc-type proc) ; 036 1073 | (simple (3-normalise* args env ; 037 1074 | `\(~~C1~ [['proc ~,↑proc] ['args ~,↑args] ; C1 ; 038 1075 | ['env ~,↑env] ['cont ~,↑cont]] ; 039 1076 | '[args*] ; 040 1077 | '(cond [(= proc* ↑referent) ; 041 1078 | (normalise ↓(1st args) ↓(2nd args) cont)] ; 042 [sic. indentation] 1079 | [(primitive proc*) (cont ↑(↓proc* . ↓args*))] ; 043 1080 | [$T (normalise (body proc*) ; 044 1081 | (bind (pattern proc*) args* (env proc*)) ; 045 1082 | cont)])))) ; 046 [sic. indentation] 1083 | (reflect (let ((nlevel (3-increment-level)) ; REFLECT UP! ; 047 1084 | (proc (cdr proc))) ; =========== ; 048 1085 | (3-normalise* ↓(3r-3rd proc) ; 049 1086 | (3-bind ↓(3r-2nd proc) ; 050 1087 | `\[~,↑args ~,env ~,cont] ; 051 1088 | (3r-1st proc)) ; 052 1089 | (cdr nlevel))))))) ; 053 1090 | ; Page 5:1 ; [sic. no line number] 1091 | ; 054 1092 | ;;; C1: Accept the normalised arguments to a SIMPLE application. Dispatch 055 1093 | ;;; --- on primitives, and reflect down in case we encounter a call to a 056 1094 | ;;; continuation we ourselves once put together. Also trap explicit calls 057 1095 | ;;; to NORMALISE and REDUCE, for efficiency. 058 1096 | ; 059 1097 | (defun ~C1~ (env cont args*) ; 060 1098 | (declare (ignore cont)) ; 061 1099 | (let ((proc (3a-1st env))) ; 062 1100 | (cond ((eq (car proc) '~PRIM~) ; 063 1101 | (3-argument-check args* proc) ; 064 1102 | (3-primitive-reduce-simple (3-primitive-simple-id proc) ; 065 1103 | args* ; 066 1104 | (3a-4th env))) ; 067 1105 | ((memq (car proc) 3=simple-aliases) ; 068 1106 | (3-drop-level (3a-3rd env) (3a-4th env)) ; REFLECT DOWN ; 069 1107 | (3-apply proc ↓(3r-1st args*))) ; ============ ; 070 1108 | ((eq proc 3=normalise-closure) ; 071 1109 | (3-drop-level (3a-3rd env) (3a-4th env)) ; REFLECT DOWN ; 072 1110 | (3-normalise* ↓(3r-1st args*) ; ============ ; 073 1111 | (3r-2nd args*) ; 074 1112 | (3r-3rd args*))) ; 075 1113 | ((eq proc 3=reduce-closure) ; 076 1114 | (3-drop-level (3a-3rd env) (3a-4th env)) ; REFLECT DOWN ; 077 1115 | (3-reduce ↓(3r-1st args*) ; ============ ; 078 1116 | ↓(3r-2nd args*) ; 079 1117 | (3r-3rd args*) ; 080 1118 | (3r-4th args*))) ; 081 1119 | (t (let ((proc* (cdr proc))) ; 082 1120 | (3-normalise* ; 083 1121 | ↓(3r-3rd proc*) ; 084 1122 | (3-bind ↓(3r-2nd proc*) args* (3r-1st proc*)) ; 085 1123 | (3a-4th env))))))) ; 086 1124 | ; 087 1125 | ;;; C2: Accept the normalised first element in a rail fragment. 088 1126 | ;;; --- Normalise the rest. 089 1127 | ; 090 1128 | (defun ~C2~ (env cont element*) ; 091 1129 | (declare (ignore cont)) ; 092 1130 | (3-normalise-rail ; 093 1131 | (3-tail* 1 (3a-1st env)) ; 094 1132 | (3a-2nd env) ; 095 1133 | `\(~~C3~ ~,(nconc `\[['element* ~,↑element*]] env) ; C3 ; 096 1134 | '[rest*] ; 097 1135 | '(cont (prep element* rest*))))) ; 098 1136 | ; 099 1137 | ;;; C3: Accept the normalised tail of a rail fragment. Put the first 100 1138 | ;;; --- element on the front. 101 1139 | ; 102 1140 | (defun ~C3~ (env cont rest*) ; 103 1141 | (declare (ignore cont)) ; 104 1142 | (3-apply (3a-4th env) (nconc `\[~,(3a-1st env)] rest*))) ; 105 1143 | ; 106 1144 | ;;; C4: Accept an expression normalised for the top level of a 107 1145 | ;;; --- READ-NORMALISE-PRINT loop. Print it out and read another. 108 1146 | ;;; 109 1147 | ;;; On entry here ENV will be bound to the environment of the C4 closure, CONT 110 1148 | ;;; will be bound to the whole C4 closure, and NORMAL-FORM will be bound to a 111 1149 | ;;; designator of the result of the NORMALISE at the level below. 112 1150 | ; 113 1151 | (defun ~C4~ (env cont normal-form) ; 114 1152 | (3-prompt 3=level ":") ; 115 1153 | (3-print ↓normal-form) ; 116 1154 | (3-prompt 3=level) ; 117 1155 | (3-drop-level 3=global-environment cont) ; 118 1156 | (3-normalise* (3-read) (3-binding 'env env) 3=id-closure)) ; 119 1157 | ; 120 1158 | ;;; C5: Accept the result of normalising an expression wrapped in an 121 1159 | ;;; --- IN-3-LISP macro. Return answer to the caller. 122 1160 | ; 123 1161 | (defun ~C5~ (env cont normal-form) ; 124 1162 | (declare (ignore env cont)) ; 125 1163 | (throw '3-exit normal-form)) ; 126 1164 | ; 127 1165 | (defun 3-argument-check (args proc) ; 128 1166 | (let ((pattern ↓(3r-2nd (cdr proc)))) ; 129 1167 | (if (and (3-rail pattern) ; 130 1168 | (not (= (3-length args) (3-length pattern)))) ; 131 1169 | (3-error '|Wrong number of arguments to a primitive: | ; 132 1170 | `\(~,(car ↓(3r-3rd proc)) . ~,args))))) ; 133 1171 | ; 134 1172 | ; Page 6 ; 001 1173 | ;;; Environments: 002 1174 | ;;; ============= 003 1175 | ;;; 004 1176 | ;;; 3-BINDING Look up a binding in a 3-LISP standard environment 005 1177 | ;;; --------- designator, but, for efficiency, bypass rail type-checking. 006 1178 | ; 007 1179 | (defun 3-binding (var env) ; 008 1180 | (3-atom-check var) ; 009 1181 | (3-rail-check env) ; 010 1182 | (do ((env (3-strip env) (3-strip env))) ; 011 1183 | ((null env) (3-error `(,var unbound variable -- BINDING))) ; 012 1184 | (if (eq var ↓(3r-1st (car env))) (return ↓(3r-2nd (car env)))))) ; 013 1185 | ; 014 1186 | ;;; 3-BIND Bind variable structure to argument structure. Destructures on 015 1187 | ;;; ------ rails and sequences. For efficiency, does rail manipulation by 016 1188 | ;;; itself, saving time and cons'es. The DO constructs a reversed 017 1189 | ;;; MACLISP rail designator, NREVERSEd on exit. 018 1190 | ; 019 1191 | (defun 3-bind* (pattern vals) ; 020 1192 | (case (3-type pattern) ; 021 1193 | (atom `(\[~,↑pattern ~,↑vals])) ; 022 1194 | (rail (case (3-type vals) ; 023 1195 | (rail (do ((binds nil (nconc (3-bind* (car pattern) (car vals)) binds)) ; 024 1196 | (pattern (3-strip pattern) (3-strip pattern)) ; 025 1197 | (vals (3-strip vals) (3-strip vals))) ; 026 1198 | ((or (null pattern) (null vals)) ; 027 1199 | (cond ((and (null pattern) (null vals)) ; 028 1200 | (nreverse binds)) ; 029 1201 | ((null vals) (3-error '|Too few arguments supplied to rail|)) ; 030 1202 | (t (3-error '|Too many arguments supplied to rail|)))))) ; 031 1203 | (handle (if (3-rail ↓vals) ; 032 1204 | (do ((binds nil (nconc (3-bind* (car pattern) ↑(car vals)) ; 033 1205 | binds)) ; 034 1206 | (pattern (3-strip pattern) (3-strip pattern)) ; 035 1207 | (vals (3-strip ↓vals) (3-strip vals))) ; 036 1208 | ((or (null pattern) (null vals)) ; 037 1209 | (cond ((and (null pattern) (null vals)) ; 038 1210 | (nreverse binds)) ; 039 1211 | ((null vals) (3-error '|Too few arguments supplied|)) ; 040 1212 | (t (3-error '|Too many arguments supplied|))))) ; 041 1213 | (3-type-error vals '|ATOM, RAIL, or RAIL DESIGNATOR to handle|))) ; 042 1214 | (t (3-type-error vals '|ATOM, RAIL, OR RAIL DESIGNATOR to rail|)))) ; 043 1215 | (t (3-type-error vals '|ATOM, RAIL, OR RAIL DESIGNATOR|)))) ; 044 1216 | ; 045 1217 | (defun 3-rebind (var binding env) ; 046 1218 | (3-atom-check var) ; 047 1219 | (3-rail-check env) ; 048 1220 | (if (not (3-normal binding)) ; 049 1221 | (3-error '(binding not in normal form -- REBIND) binding)) ; 050 1222 | (do ((env (3-strip* env) (3-strip* (cdr env)))) ; 051 1223 | ((null (cdr env)) (nconc env `\[[~,↑var ~,binding]])) ; 052 1224 | (if (eq var ↓(3r-1st (cadr env))) ; 053 1225 | (return (3-rplacn 2 (cadr env) binding)))) ; 054 1226 | binding) ; 055 1227 | ; 056 1228 | ; Page 7 ; 001 1229 | ;;; Reflective state management: 002 1230 | ;;; ============================ 003 1231 | ;;; 004 1232 | ;;; 3=STATES is a queue of the environment and continuation of each reflective 005 1233 | ;;; level ABOVE the current one (the value of 3=LEVEL), if they were ever 006 1234 | ;;; explicitly generated (all relevant ones BELOW the current level are of 007 1235 | ;;; course being passed around explicitly in 3-LISP programs). 008 1236 | ; 009 1237 | (defun 3-drop-level (env cont) ; 010 1238 | (push (cons env cont) 3=states) ; 011 1239 | (setq 3=level (1- 3=level))) ; 012 1240 | ; 013 1241 | (defun 3-increment-level () ; 014 1242 | (setq 3=level (1+ 3=level)) ; 015 1243 | (if (not (null 3=states)) ; 016 1244 | (pop 3=states) ; 017 1245 | (cons 3=global-environment ; 018 1246 | `\(~~C4~ ~,(nconc `\[['env ~,↑3=global-environment]] ; 019 1247 | 3=global-environment) ; 020 1248 | '[normal-form] ; 021 1249 | '(block (prompt (level)) ; 022 1250 | (print normal-form) ; 023 1251 | (read-normalise-print env)))))) ; 024 1252 | ; 025 1253 | ; Page 8 ; 001 1254 | ;;; Rail Management: 002 1255 | ;;; ================ 003 1256 | ;;; 004 1257 | ;;; 005 1258 | ;;; 3-RCONS Make a new rail (or sequence designator) out of the args 006 1259 | ;;; 3-SCONS 007 1260 | ;;; ------- 008 1261 | ; 009 1262 | (defun 3-rcons (args) ; 010 1263 | (do ((args (3-strip (3-rail-check args)) (3-strip args)) ; 011 1264 | (new nil (cons ↓(car args) new))) ; 012 1265 | ((null args) ↑(cons '~RAIL~ (nreverse new))))) ; 013 1266 | ; 014 1267 | (defun 3-scons (args) ; 015 1268 | (do ((args (3-strip (3-rail-check args)) (3-strip args)) ; 016 1269 | (new nil (cons (car args) new))) ; 017 1270 | ((null args) (cons '~RAIL~ (nreverse new))))) ; 018 1271 | ; 019 1272 | ;;; 3-RS Macro that takes two forms, one for rails and one for sequences, 020 1273 | ;;; ---- and wraps the appropriate type dispatch around them. 021 1274 | ; 022 1275 | (defmacro 3-rs (exp rail-form seq-form) ; 023 1276 | `(case (3-type ,exp) ; 024 1277 | (handle ,rail-form) ; 025 1278 | (rail ,seq-form) ; 026 1279 | (t (3-ref-type-error ,exp '|RAIL OR SEQUENCE|)))) ; 027 1280 | ; 028 1281 | ;;; 3-PREP -- These four kinds are defined over both rails and sequences. 029 1282 | ;;; 3-LENGTH They are all defined in terms of *-versions, which operate 030 1283 | ;;; 3-TAIL on the implementing rails. 031 1284 | ;;; 3-NTH 032 1285 | ; 033 1286 | (defun 3-prep (el exp) ; 034 1287 | (3-rs exp ↑(list* '~RAIL~ ↓el (3-rail-check ↓exp)) ; 035 1288 | (list* '~RAIL~ el exp))) ; 036 1289 | ; 037 1290 | (defun 3-length (exp) ; 038 1291 | (3-rs exp (3-length* (3-rail-check ↓exp)) ; 039 1292 | (3-length* exp))) ; 040 1293 | ; 041 1294 | (defun 3-tail (n exp) ; 042 1295 | (3-rs exp ↑(3-tail* n (3-rail-check ↓exp)) ; 043 1296 | (3-tail* n exp))) ; 044 1297 | ; 045 1298 | (defun 3-nth (n exp) ; 046 1299 | (3-rs exp ↑(car (3-nthcdr* n (3-rail-check ↓exp))) ; 047 1300 | (car (3-nthcdr* n exp)))) ; 048 1301 | ; 049 1302 | ;;; 3-RPLACN Defined only on RAILS. 050 1303 | ;;; -------- 051 1304 | ; 052 1305 | (defun 3-rplacn (n rail el) ; 053 1306 | (rplaca (3-nthcdr* n (3-rail-check rail)) el) ; 054 1307 | rail) ; 055 1308 | ; 056 1309 | (defun 3-nthcdr* (n rail) ; 057 1310 | (if (< n 1) (3-index-error n rail)) ; 058 1311 | (do ((i 1 (1+ i)) ; 059 1312 | (rest (3-strip rail) (3-strip rest))) ; 060 1313 | ((or (= n i) (null rest)) ; 061 1314 | (if (null rest) ; 062 1315 | (3-index-error n rail) ; 063 1316 | rest)))) ; 064 1317 | ; Page 8:1 ; 065 1318 | (defun 3-tail* (n o-rail) ; 066 1319 | (if (< n 0) (3-index-error n o-rail)) ; 067 1320 | (if (zerop n) ; 068 1321 | o-rail ; 069 1322 | (do ((i 0 (1+ i)) ; 070 1323 | (rail (3-strip* o-rail) (3-strip* (cdr rail)))) ; 071 1324 | ((or (= n i) (null (cdr rail))) ; 072 1325 | (if (= n i) ; 073 1326 | (if (eq (car rail) '~RAIL~) ; 074 1327 | rail ; 075 1328 | (let ((tail (cons '~RAIL~ (cdr rail)))) ; 076 1329 | (rplacd rail tail) ; Splice in a new header ; 077 1330 | tail)) ; 078 1331 | (3-error `(,n is too large for a tail of) o-rail)))))) ; 079 1332 | ; 080 1333 | ;;; RPLACT is what all the trouble is about. A tempting implementation is: 081 1334 | ;;; 082 1335 | ;;; (defmacro 3-rplact (n r1 r2) `(cdr (rplacd (3-tail ,n ,r1) ,r2))) 083 1336 | ;;; 084 1337 | ;;; but this has two problems. First, it can generate an unnecessary header, 085 1338 | ;;; since 3-TAIL may construct one, even though r2 is guaranteed to have one 086 1339 | ;;; already. Second, some uses of this (such as (RPLACT 1 X X)) would generate 087 1340 | ;;; circular structures. The following version avoids these problems: 088 1341 | ; 089 1342 | (defun 3-rplact (n r1 r2) ; 090 1343 | (3-rail-check r1) ; 091 1344 | (3-rail-check r2) ; 092 1345 | (if (< n 0) (3-index-error n r1)) ; 093 1346 | (do ((i 0 (1+ i)) ; 094 1347 | (last r1 rail) ; 095 1348 | (rail (3-strip* r1) (3-strip* (cdr rail)))) ; 096 1349 | ((or (= n i) (null (cdr rail))) ; 097 1350 | (progn ; 098 1351 | (if (not (= n i)) (3-index-error n r1)) ; 099 1352 | (if (let ((r2-headers (do ((r2 r2 (cdr r2)) ; 100 1353 | (heads nil (cons r2 heads))) ; 101 1354 | ((not (eq (car r2) '~RAIL~)) heads)))) ; 102 1355 | (do ((r1-header (cdr last) (cdr r1-header))) ; 103 1356 | ((not (eq (car r1-header) '~RAIL~)) 't) ; 104 1357 | (if (memq r1-header r2-headers) (return 'nil)))) ; 105 1358 | (rplacd rail r2)) ; 106 1359 | r1)))) ; 107 1360 | ; 108 1361 | ; Page 9 ; 001 1362 | ;;; Typing and Type Checking: 002 1363 | ;;; ========================= 003 1364 | ; 004 1365 | ;;; 3-boolean and 3-numeral are macros, defined above. 017 1366 | ; 018 1367 | (defun 3-atom (e) (and (symbolp e) (not (memq e '($T $F))))) ; 019 1368 | (defun 3-rail (e) (and (list? e) (eq (car e) '~RAIL~))) ; 020 1369 | (defun 3-pair (e) (eq (3-type e) 'pair)) ; 021 1370 | ; 022 1371 | (eval-when (:load-toplevel :execute :compile-toplevel) ; 023 1372 | (defun 3-handle (e) (and (list? e) (eq (car e) '~QUOTE~))) ; 024 1373 | ) ; 025 1374 | ; 026 1375 | (defun 3-atom-check (e) (if (3-atom e) e (3-type-error e 'atom))) ; 027 1376 | (defun 3-rail-check (e) (if (3-rail e) e (3-type-error e 'rail))) ; 028 1377 | (defun 3-pair-check (e) (if (3-pair e) e (3-type-error e 'pair))) ; 029 1378 | (defun 3-handle-check (e) (if (3-handle e) e (3-type-error e 'handle))) ; 030 1379 | (defun 3-num-check (e) (if (3-numeral e) e (3-type-error e 'numeral))) ; 031 1380 | (defun 3-bool-check (e) (if (3-boolean e) e (3-type-error e 'boolean))) ; 032 1381 | ; 033 1382 | ;;; 3-REF-TYPE Returns the type of the entity designated by the 3-LISP 034 1383 | ;;; ---------- object encoded as the argument. 035 1384 | ; 036 1385 | (defun 3-ref-type (exp) ; 037 1386 | (case (3-type exp) ; 038 1387 | (numeral 'number) ; 039 1388 | (boolean 'truth-value) ; 040 1389 | (rail 'sequence) ; 041 1390 | (handle (3-type (cdr exp))) ; 042 1391 | (pair (if (or (eq (car exp) 3=simple-closure) ; 043 1392 | (eq (car exp) 3=reflect-closure) ; 044 1393 | (memq (car exp) 3=simple-aliases)) ; 045 1394 | 'function ; 046 1395 | (3-error '(not in normal form -- REF-TYPE) exp))) ; 047 1396 | (atom (3-error '(not in normal form -- REF-TYPE) exp)))) ; 048 1397 | ; 049 1398 | ;;; 3-REF Returns the referent of the argument, which must either be a 050 1399 | ;;; ----- handle or a rail of handles, since the only kinds of ref's we 051 1400 | ;;; can return are s-expressions. 052 1401 | ; 053 1402 | (defun 3-ref (exp) ; 054 1403 | (cond ((3-handle exp) (cdr exp)) ; 055 1404 | ((3-rail exp) ; 056 1405 | (do ((rail (3-strip exp) (3-strip rail)) ; 057 1406 | (elements nil (cons ↓(car rail) elements))) ; 058 1407 | ((null rail) (cons '~RAIL~ (nreverse elements))) ; 059 1408 | (if (not (3-handle (car rail))) ; 060 1409 | (3-ref-type-error exp '|SEQUENCE OF S-EXPRESSIONS|)))) ; 061 1410 | (t (3-ref-type-error exp '|S-EXPRESSION OR SEQUENCE OF S-EXPRESSIONS|)))) ; 062 1411 | ; 063 1412 | ;;; 3-PROC-TYPE Returns the procedure type of the argument 064 [sic. no full stop] 1413 | ;;; ----------- 065 1414 | ; 066 1415 | (defun 3-proc-type (proc) ; 067 1416 | (3-pair-check proc) ; 068 1417 | (cond ((eq (car proc) 3=simple-closure) 'simple) ; 069 1418 | ((memq (car proc) 3=simple-aliases) 'simple) ; 070 1419 | ((eq (car proc) 3=reflect-closure) 'reflect) ; 071 1420 | (t (3-type-error proc 'closure)))) ; 072 1421 | ;;; ; Page 10 ; 001 1422 | ;;; Identity and Normal-form Predicates: 002 1423 | ;;; ==================================== 003 1424 | ;;; 004 1425 | ;;; 005 1426 | ;;; 3-CANONICALISE Maps aliases onto their proper identity. 006 1427 | ;;; -------------- 007 1428 | ; 008 1429 | (defun 3-canonicalise (exp) ; 009 1430 | (if (and (symbolp exp) (memq exp 3=simple-aliases)) ; 010 1431 | 3=simple-closure ; 011 1432 | exp)) ; 012 1433 | ; 013 1434 | ;;; 3-EQUAL True just in case arguments implement the same 3-LISP object. 014 1435 | ;;; ------- 015 1436 | ; 016 1437 | (defun 3-equal (e1 e2) ; 017 1438 | (and (eq (3-type e1) (3-type e2)) ; 018 1439 | (case (3-type e1) ; 019 1440 | (handle (let ((r1 (3-canonicalise ↓e1)) ; 020 1441 | (r2 (3-canonicalise ↓e2))) ; 021 1442 | (or (eq r1 r2) ; 022 1443 | (and (3-rail r1) ; 023 1444 | (3-rail r2) ; 024 1445 | (eq (3-strip* r1) (3-strip* r2))) ; 025 1446 | (and (3-handle r1) ; 026 1447 | (3-handle r2) ; 027 1448 | (3-equal r1 r2))))) ; 028 1449 | (boolean (eq e1 e2)) ; 029 1450 | (numeral (= e1 e2)) ; 030 1451 | (rail (do ((e1 (3-strip e1) (3-strip e1)) ; 031 1452 | (e2 (3-strip e2) (3-strip e2))) ; 032 1453 | ((null e1) (null e2)) ; 033 1454 | (if (not (3-equal (car e1) (car e2))) ; 034 1455 | (return 'nil)))) ; 035 [next line is 036] 1456 | (t (3-error '|= is defined only over s-expressions, 1457 | numerals, truth-values, and some sequences|))))) ; 037 1458 | ; 038 1459 | ;;; 3-NORMAL True in case argument is in normal form. 039 1460 | ;;; -------- 040 1461 | ; 041 1462 | (defun 3-normal (exp) ; 042 1463 | (or (3-handle exp) (3-pnormal exp))) ; 043 1464 | ; 044 1465 | (defun 3-pnormal (exp) ; 045 1466 | (or (fixp exp) ; 046 1467 | (memq exp '($T $F)) ; 047 1468 | (and (list? exp) ; 048 1469 | (or (eq (car exp) 3=simple-closure) ; 049 1470 | (eq (car exp) 3=reflect-closure) ; 050 1471 | (memq (car exp) 3=simple-aliases)) ; 051 1472 | (3-rail (cdr exp)) ; 052 1473 | (3-normal (3r-1st (cdr exp))) ; 053 1474 | (3-normal (3r-2nd (cdr exp))) ; 054 1475 | (3-normal (3r-3rd (cdr exp)))) ; 055 1476 | (and (3-rail exp) ; 056 1477 | (do ((exp (3-strip exp) (3-strip exp))) ; 057 1478 | ((null exp) 't) ; 058 1479 | (if (not (3-normal (car exp))) (return 'nil)))))) ; 059 1480 | ; 060 1481 | ; Page 11 ; 001 1482 | ;;; Top Level: 002 1483 | ;;; ========== 003 1484 | ; 004 1485 | (defmacro loop-catch (tag &rest body) ; 005 1486 | `(do nil (nil) (catch ,tag ,@body))) ; 006 1487 | ; 007 1488 | ;;; 3-LOGIN Used only for obscure reasons on the LISP machine, having 008 1489 | ;;; 3-LOGOUT to do with compatibility with other users, recovery from 009 1490 | ;;; -------- warm boots, and so forth. 010 1491 | ; 011 1492 | (defun 3-logout () ; 012 1493 | (setq *readtable* S=readtable)) ; 015 1494 | ; 016 1495 | (defun 3-login () ; 017 1496 | (or (boundp '3=global-environment) (3-init)) ; 018 1497 | (setq base 10. ibase 10. *nopoint t) ; 019 1498 | (setq *readtable* L=readtable)) ; 020 1499 | ; 021 1500 | ;;; 3-LISP Starts up the 3-LISP processor. The 3-LEVEL-LOOP loop is 022 1501 | ;;; ------ only run on initialisation and errors; otherwise the 023 1502 | ;;; READ-NORMALISE-PRINT loop is run out of ~C4~. 024 1503 | ; 025 1504 | (defun 3-lisp () ; 026 1505 | (or (boundp '3=global-environment) (3-init)) ; 030 1506 | (catch '3-exit ; 031 1507 | (loop-catch '3-top-loop ; 032 1508 | (let ((3=in-use t)) ; 033 1509 | (setq 3=level 0 ; 034 1510 | 3=states nil) ; 035 1511 | (loop-catch '3-level-loop ; 036 1512 | (3-prompt (1+ 3=level)) ; 037 1513 | (setq 3=a1 (3-read) ; 038 1514 | 3=a2 3=global-environment ; 039 1515 | 3=a3 3=id-closure) ; 040 1516 | (loop-catch '3-main-loop (3-normalise 3=a1 3=a2 3=a3))))))) ; 041 1517 | ; 042 1518 | ;;; 3-LISPIFY Normalises its argument (should be a 3-LISP expression) 043 1519 | ;;; --------- at the top level of the level 1 3-LISP environment (intended 044 1520 | ;;; for use by IN-3-LISP). 045 1521 | ; 046 1522 | (defun 3-lispify (expr) ; 047 1523 | (setq 3=level 1 ; 048 1524 | 3=states nil ; 049 1525 | 3=a1 expr ; 050 1526 | 3=a2 3=global-environment ; 051 1527 | 3=a3 `\(~~C5~ ~,3=a2 [])) ; 052 1528 | (catch '3-exit ; 053 1529 | (loop-catch '3-main-loop (3-normalise 3=a1 3=a2 3=a3)))) ; 054 1530 | ; 055 1531 | ; Page 12 ; 001 1532 | ;;; Errors and Interrupts: 002 1533 | ;;; ====================== 003 1534 | ; 004 1535 | ; 093 1536 | ; Page 13 ; 001 1537 | ;;; Initialisation: 002 1538 | ;;; =============== 003 1539 | ; 004 1540 | (defun 3-init () ; 005 1541 | (princ '| (initialising 3-LISP reflective model -- this takes a few minutes)|) ; 006 1542 | (setq ; 007 1543 | 3=in-use nil ; 008 1544 | 3=level 1 ; 009 1545 | 3=break-flag t ; 010 1546 | 3=simple-aliases '(~C0~ ~C1~ ~C2~ ~C3~ ~C4~ ~C5~ ~PRIM~) ; 011 1547 | 3=normalise-closure nil ; These will be set to real values ; 012 1548 | 3=reduce-closure nil ; later, but will be referenced first ; 013 1549 | 3=id-closure nil ; 014 1550 | 3=global-environment (3-initial-environment) ; 015 1551 | prinlength 6 ; In case environments ; 016 1552 | prinlevel 4 ; are printed by LISP ; 017 1553 | base 10. ; Since 3-LISP assumes base 10 integers ; 018 1554 | ibase 10. ; and we use the straight LISP printer ; 019 1555 | *nopoint T) ; 020 1556 | (setq 3=simple-closure (3-binding 'simple 3=global-environment) ; 021 [sic. indentation] 1557 | 3=reflect-closure (3-binding 'reflect 3=global-environment)) ; 022 1558 | (3-define-utilities-0) ; 023 1559 | (3-define-reflective) ; 024 1560 | (setq 3=normalise-closure (3-binding 'normalise 3=global-environment) ; 025 1561 | 3=reduce-closure (3-binding 'reduce 3=global-environment)) ; 026 1562 | (3-define-utilities-1) ; The order here is crucial: have to ; 027 1563 | (setq 3=id-closure (3-binding 'id 3=global-environment)) ; 028 1564 | (3-define-utilities-2) ; get the def's marked before these. ; 029 [sic. stop] 1565 | (3-define-utilities-3)) ; 030 1566 | ; 031 1567 | ;;; 3-INITIAL-ENVIRONMENT Returns a new initialised 3-LISP environment, 032 1568 | ;;; --------------------- with each of the names of primitive functions 033 1569 | ;;; bound to a circular definition, closed in the new 034 1570 | ;;; environment, that betrays both the type and the number of arguments. For 035 1571 | ;;; example, CAR is bound to the normalisation of (LAMBDA SIMPLE [X] (CAR X)). 036 1572 | ;;; This could just be a constant list that was copied, but is instead 037 1573 | ;;; generated by the following function, that fakes the normalisation process 038 1574 | ;;; and then side-effects the result to make the environment structures 039 1575 | ;;; circular. 040 1576 | ; 041 1577 | (defun 3-initial-environment () ; 042 1578 | (let ((env `\[['global ~~~~] ; 043 1579 | ~,@(mapcar '3-make-primitive-closure ; 044 1580 | (3-circular-closures))])) ; 045 1581 | (mapcar #'(lambda (entry) ; 046 1582 | (3-rplacn 1 (cdr ↓(3r-2nd entry)) env)) ; 047 1583 | (cddr env)) ; 048 1584 | (3-rplacn 2 (3r-1st env) ↑env) ; 049 1585 | env)) ; 050 1586 | ; 051 1587 | ;;; 3-MAKE-PRIMITIVE-CLOSURE Constructs the primitive definitions. 052 1588 | ;;; ------------------------ 053 1589 | ; 054 1590 | (defun 3-make-primitive-closure (entry) ; 055 1591 | (let ((name (car entry)) ; 056 1592 | (def (cdadr entry))) ; 057 1593 | `\[~,↑name ~,↑(cons '~PRIM~ `\[~~dummy~ ~,↑(3r-2nd def) ~,↑(3r-3rd def)])])) ; 058 1594 | ; 059 1595 | (defun 3-circular-closures () ; 060 1596 | '((terpri \(lambda simple [] (terpri))) ; 061 1597 | (read \(lambda simple [] (read))) ; 062 1598 | (type \(lambda simple [exp] (type exp))) ; 063 1599 | (car \(lambda simple [pair] (car pair))) ; 064 1600 | (cdr \(lambda simple [pair] (cdr pair))) ; 065 1601 | (length \(lambda simple [vector] (length vector))) ; 066 1602 | (print \(lambda simple [exp] (print exp))) ; 067 1603 | (name \(lambda simple [exp] (name exp))) ; 068 1604 | (= \(lambda simple [a b] (= a b))) ; 069 1605 | (pcons \(lambda simple [a b] (pcons a b))) ; 070 1606 | (rcons \(lambda simple args (rcons . args))) ; 071 1607 | (scons \(lambda simple args (scons . args))) ; 072 1608 | (prep \(lambda simple [element vector] (prep element vector))) ; 073 1609 | (nth \(lambda simple [n vector] (nth n vector))) ; 074 1610 | (tail \(lambda simple [n vector] (tail n vector))) ; 075 1611 | (rplaca \(lambda simple [a pair] (rplaca a pair))) ; 076 1612 | (rplacd \(lambda simple [d pair] (rplacd d pair))) ; 077 1613 | (rplacn \(lambda simple [n rail element] (rplacn n rail element))) ; 078 1614 | (rplact \(lambda simple [n rail tail] (rplact n rail tail))) ; 079 1615 | (+ \(lambda simple [a b] (+ a b))) ; 080 1616 | (- \(lambda simple [a b] (- a b))) ; 081 1617 | (* \(lambda simple [a b] (* a b))) ; 082 1618 | (/ \(lambda simple [a b] (/ a b))) ; 083 1619 | (referent \(lambda simple [exp env] (referent exp env))) ; 084 1620 | (simple \(lambda simple [env pattern body] (simple env pattern body))) ; 085 1621 | (reflect \(lambda simple [env pattern body] (reflect env pattern body))) ; 086 1622 | (ef \(lambda simple [premise c1 c2] (ef premise c1 c2))) ; 087 1623 | (*rebind \(lambda simple [var binding env] (*rebind var binding env))) ; 088 1624 | (level \(lambda simple [] (level))))) ; 089 1625 | ; 090 1626 | ; Page 14 ; 001 1627 | ;;; 3-LISP: Reflective Processor: 002 1628 | ;;; ============================== 003 1629 | ; 004 1630 | (defun 3-define-reflective () ; 005 1631 | (in-3-lisp \[ ; 006 1632 | ; 007 1633 | (define READ-NORMALISE-PRINT ; 008 1634 | (lambda simple [env] ; 009 1635 | (block (prompt (level)) ; 010 1636 | (let [[normal-form (normalise (read) env id)]] ; 011 1637 | (block (prompt (level)) ; 012 1638 | (print normal-form) ; 013 1639 | (read-normalise-print env)))))) ; 014 1640 | ; 015 1641 | (define NORMALISE ; 016 1642 | (lambda simple [exp env cont] ; 017 1643 | (cond [(normal exp) (cont exp)] ; 018 1644 | [(atom exp) (cont (binding exp env))] ; 019 1645 | [(rail exp) (normalise-rail exp env cont)] ; 020 1646 | [(pair exp) (reduce (car exp) (cdr exp) env cont)]))) ; 021 1647 | ; 022 1648 | (define REDUCE ; 023 1649 | (lambda simple [proc args env cont] ; 024 1650 | (normalise proc env ; 025 1651 | (lambda simple [proc*] ; C0 ; 026 1652 | (selectq (procedure-type proc*) ; 027 1653 | [reflect ((simple . ↓(cdr proc*)) args env cont)] ; 028 1654 | [simple (normalise args env (make-c1 proc* cont))]))))) ; 029 1655 | ; 030 1656 | (define MAKE-C1 ; 031 1657 | (lambda simple [proc* cont] ; 032 1658 | (lambda simple [args*] ; C1 ; 033 1659 | (cond [(= proc* ↑referent) ; 034 1660 | (normalise ↓(1st args) ↓(2nd args) cont)] ; 035 1661 | [(primitive proc*) (cont ↑(↓proc* . ↓args*))] ; 036 1662 | [$T (normalise (body proc*) ; 037 1663 | (bind (pattern proc*) args* (env proc*)) ; 038 1664 | cont)])))) ; 039 1665 | ; 040 1666 | (define NORMALISE-RAIL ; 041 1667 | (lambda simple [rail env cont] ; 042 1668 | (if (empty rail) ; 043 1669 | (cont `[]) ; 044 1670 | (normalise (1st rail) env ; 045 1671 | (lambda simple [element*] ; C2 ; 046 1672 | (normalise-rail (rest rail) env ; 047 1673 | (lambda simple [rest*] ; C3 ; 048 1674 | (cont (prep element* rest*))))))))) ; 049 1675 | ; 050 1676 | ])) ; 051 1677 | ; 052 1678 | ; Page 15 001 1679 | ;;; 3-LISP: Utility Support: 002 1680 | ;;; ========================= 003 1681 | ; 004 1682 | ;;; 3-DEFINE-UTILITIES-0 sets up the definitions of SET, DEFINE, LAMBDA, 005 1683 | ;;; and Z, so that subsequent defining can proceed regularly. The technique 006 1684 | ;;; is to bootstrap our way up through temporary versions of a bunch of 007 1685 | ;;; procedures, so as to put ourselves into a position where more adequate 008 1686 | ;;; versions can be manageable defined. 009 [sic. leg. "manageably"] 1687 | ; 010 1688 | (defun 3-define-utilities-0 () ; 011 1689 | (in-3-lisp \[ ; 012 1690 | ; 013 1691 | ;;; First define CURRENT-ENV (so that down-arrow can work) and LAMBDA: 014 1692 | ; 015 1693 | (rplact (length global) ; 016 1694 | ↑global ; 017 1695 | `[['CURRENT-ENV ,↑↑(reflect [['name ↑name]] ; 018 1696 | '[[] env cont] ; 019 1697 | '(cont ↑env))] ; 020 1698 | ['LAMBDA ,↑↑(reflect ((reflect [['name ↑name]] ; 021 1699 | '[[] env cont] ; 022 1700 | '(cont ↑env))) ; 023 1701 | '[[type pattern body] env cont] ; 024 1702 | '(cont ↑↓(pcons type ↑[env pattern body])))]]) ; 025 1703 | ; 026 1704 | ;;; Next tentative versions of SET, and a real version of Z (though we can't 027 1705 | ;;; use LET or BLOCK in defining Z, this definition is equivalent to the one 028 1706 | ;;; given in the text). In the following definition of &SET, *REBIND is used, 029 1707 | ;;; rather than &REBIND, for efficiency (*REBIND is provided primitively). We 030 1708 | ;;; have left in the full definition of &REBIND, to show how it would go: it 031 1709 | ;;; is merely unacceptably slow. 032 1710 | ; 033 1711 | (rplact (length global) ; 034 1712 | ↑global ; 035 1713 | `[['&SET ,↑↑(lambda reflect [[var binding] env cont] ; 036 1714 | (cont (*rebind var ↑↓binding env)))] ; 037 1715 | ['Z, ↑↑(lambda simple [fun] ; 038 1716 | ((lambda simple [temp] ; 039 1717 | ((lambda simple [closure] ; 040 1718 | ((lambda simple [? ?] temp) ; 041 1719 | (rplaca ↑temp (car closure)) ; 042 1720 | (rplacd ↑temp (cdr closure)))) ; 043 1721 | ↑(fun temp))) ; 044 1722 | (lambda simple args (error 'partial-closure-used))))]]) ; 045 1723 | ; 046 1724 | ;;; Now a temporary version of REBIND (which is recursive, and uses an explicit 047 1725 | ;;; call to Z in its construction), and a temporary DEFINE that doesn't protect Z, 048 1726 | ;;; and that expands the macro explicitly: 049 1727 | ; 050 1728 | (rplact (length global) ; 051 1729 | ↑global ; 052 1730 | `[['&REBIND ; 053 1731 | ,↑↑(Z (lambda simple [&rebind] ; 054 1732 | (lambda simple [var binding env] ; 055 1733 | ((ef (= (length env) 0) ; 056 1734 | (lambda simple [] ; 057 1735 | (rplact 0 ↑env ↑[[var binding]])) ; 058 1736 | (lambda simple [] ; 059 1737 | ((ef (= var (nth 1 (nth 1 env))) ; 060 1738 | (lambda simple [] ; 061 1739 | (rplacn 2 ↑(nth 1 env) ↑binding)) ; 062 1740 | (lambda simple [] ; 063 1741 | (&rebind var binding (tail 1 env)))))))))))] ; 064 1742 | ['DEFINE ,↑↑(lambda reflect[[label form] env cont] ; 065 1743 | ((lambda simple ? (cont label)) ; 066 1744 | ↑(referent `(&set ,label ; 067 1745 | (z (lambda simple [,label] ,form))) ; 068 1746 | env)))]]) ; 069 1747 | ])) ; 070 1748 | ; Page 15:1 071 1749 | ;;; In general there is a sense of order here: IF, for example, must preceed 072 1750 | ;;; LET; hence it cannot use LET in its own definition. And so on and so forth; 073 1751 | ;;; it takes a little care to build things up in a consistent and non-circular 074 1752 | ;;; manner. 075 1753 | ; 076 1754 | (defun 3-define-utilities-1 () ; 077 1755 | (in-3-lisp \[ ; 078 1756 | ; 079 1757 | (define ID (lambda simple [x] x)) ; 080 1758 | ; 081 1759 | (define 1ST (lambda simple [x] (nth 1 x))) ; 082 1760 | (define 2ND (lambda simple [x] (nth 2 x))) ; 083 1761 | (define 3RD (lambda simple [x] (nth 3 x))) ; 084 1762 | (define 4TH (lambda simple [x] (nth 4 x))) ; 085 1763 | ; 086 1764 | (define REST (lambda simple [x] (tail 1 x))) ; 087 1765 | (define FOOT (lambda simple [x] (tail (length x) x))) ; 088 1766 | ; 089 1767 | (define EMPTY (lambda simple [x] (= (length x) 0))) ; 090 1768 | (define UNIT (lambda simple [x] (= (length x) 1))) ; 091 1769 | (define DOUBLE (lambda simple [x] (= (length x) 2))) ; 092 1770 | ; 093 1771 | (define ATOM (lambda simple [x] (= (type x) 'atom))) ; 094 1772 | (define RAIL (lambda simple [x] (= (type x) 'rail))) ; 095 1773 | (define PAIR (lambda simple [x] (= (type x) 'pair))) ; 096 1774 | (define NUMERAL (lambda simple [x] (= (type x) 'numeral))) ; 097 1775 | (define HANDLE (lambda simple [x] (= (type x) 'handle))) ; 098 1776 | (define BOOLEAN (lambda simple [x] (= (type x) 'boolean))) ; 099 1777 | ; 100 1778 | (define NUMBER (lambda simple [x] (= (type x) 'number))) ; 101 1779 | (define SEQUENCE (lambda simple [x] (= (type x) 'sequence))) ; 102 1780 | (define TRUTH-VALUE (lambda simple [x] (= (type x) 'truth-value))) ; 103 1781 | ; 104 1782 | (define FUNCTION (lambda simple [x] (= (type x) 'function))) ; 105 1783 | ; 106 1784 | (define PRIMITIVE ; 107 1785 | (lambda simple [proc] ; 108 1786 | (member proc ; 109 1787 | ↑[type = pcons car cdr rcons scons prep length nth tail rplaca ; 110 1788 | rplacd rplacn rplact simple reflect ef name referent + * - / ; 111 1789 | read print]))) ; 112 1790 | ; 113 1791 | (define PROMPT (lambda simple [level] (block (print ↑level) (print '>)))) ; 114 1792 | ; 115 1793 | (define BINDING ; 116 1794 | (lambda simple [var env] ; 117 1795 | (cond [(empty env) (error 'unbound-variable)] ; 118 1796 | [(= var (1st (1st env))) (2nd (1st env))] ; 119 1797 | [$t (binding var (rest env))]))) ; 120 1798 | ; 121 1799 | (define ENV (lambda simple [proc] ↓(1st (cdr proc)))) ; 122 1800 | (define PATTERN (lambda simple [proc] ↓(2nd (cdr proc)))) ; 123 1801 | (define BODY (lambda simple [proc] ↓(3rd (cdr proc)))) ; 124 1802 | ; 125 1803 | (define PROCEDURE-TYPE ; 126 1804 | (lambda simple [proc] ; 127 1805 | (select (car proc) ; 128 1806 | [↑simple 'simple] ; 129 1807 | [↑reflect 'reflect]))) ; 130 1808 | ; Page 15:2 ; 131 1809 | (define XCONS ; 132 1810 | (lambda simple args ; 133 1811 | (pcons (1st args) (rcons . (rest args))))) ; 134 1812 | ; 135 1813 | (define BIND ; 136 1814 | (lambda simple [pattern args env] ; 137 1815 | ↓(join ↑(match pattern args) ↑env))) ; 138 1816 | ; 139 1817 | (define MATCH ; 140 1818 | (lambda simple [pattern args] ; 141 1819 | (cond [(atom pattern) [[pattern args]]] ; 142 1820 | [(handle args) (match pattern (map name ↓args))] ; 143 1821 | [(and (empty pattern) (empty args)) (scons)] ; 144 1822 | [(empty pattern) (error 'too-many-arguments)] ; 145 1823 | [(empty args) (error 'too-few-arguments)] ; 146 1824 | [$T ↓(join ↑(match (1st pattern) (1st args)) ; 147 1825 | ↑(match (rest pattern) (rest args)))]))) ; 148 1826 | ; 149 1827 | (define IF ; 150 1828 | (lambda reflect [args env cont] ; 151 1829 | ((ef (rail args) ; 152 1830 | (lambda simple [] ; 153 1831 | ((lambda simple [premise c1 c2] ; 154 1832 | (normalise premise env ; 155 1833 | (lambda simple [premise*] ; 156 1834 | ((ef (= premise* '$T) ; 157 1835 | (lambda simple [] (normalise c1 env cont)) ; 158 1836 | (lambda simple [] (normalise c2 env cont))))))) ; 159 1837 | . args)) ; 160 1838 | (lambda simple [] ; 161 1839 | (normalise args env ; 162 1840 | (lambda simple [[premise c1 c2]] ; 163 1841 | (cont (ef (= premise '$T) c1 c2))))))))) ; 164 1842 | ; 165 1843 | (define MEMBER ; 166 1844 | (lambda simple [element vector] ; 167 1845 | (cond [(empty vector) $F] ; 168 1846 | [(= element (1st vector)) $T] ; 169 1847 | [$t (member element (rest vector))]))) ; 170 1848 | ; 171 1849 | (define PREP* ; 172 1850 | (lambda simple args ; 173 1851 | (cond [(empty args) (error 'too-few-args)] ; 174 1852 | [(unit args) (1st args)] ; 175 1853 | [(double args) (prep . args)] ; 176 1854 | [$T (prep (1st args) (prep* . (rest args)))]))) ; 177 1855 | ; 178 1856 | (define NORMAL ; 179 1857 | (lambda simple [x] ; 180 1858 | (selectq (type x) ; 181 1859 | [numeral $T] ; 182 1860 | [boolean $T] ; 183 1861 | [handle $T] ; 184 1862 | [atom $F] ; 185 1863 | [rail (and . (map normal x))] ; 186 1864 | [pair (and (member (car pair) ↑[simple reflect]) ; 187 1865 | (normal (cdr pair)))]))) ; 188 1866 | ; 189 1867 | (define NOT (lambda simple [x] (if x $F $T))) ; 190 1868 | ; Page 15:3 ; 191 1869 | (define COPY ; 192 1870 | (lambda simple [rail] ; 193 1871 | (if (empty rail) ; 194 1872 | (rcons) ; 195 1873 | (prep (1st rail) (copy (rest rail)))))) ; 196 1874 | ; 197 1875 | (define JOIN ; 198 1876 | (lambda simple [rail1 rail2] ; 199 1877 | (rplact (length rail1) rail1 rail2))) ; 200 1878 | ; 201 1879 | (define APPEND ; 202 1880 | (lambda simple [rail1 rail2] ; 203 1881 | (join (copy . rail1) rail2))) ; 204 1882 | ; 205 1883 | (define REDIRECT ; 206 1884 | (lambda simple [index rail new-tail] ; 207 1885 | (if (< index 1) ; 208 1886 | (error 'redirect-called-with-too-small-an-index) ; 209 1887 | (rplact (- index 1) ; 210 1888 | rail ; 211 1889 | (prep (nth index rail) new-tail))))) ; 212 1890 | ; 213 1891 | (define PUSH ; 214 1892 | (lambda simple [element stack] ; 215 1893 | (rplact 0 stack ; 216 1894 | (prep element ; 217 1895 | (if (empty stack) ; 218 1896 | `[] ; 219 1897 | (prep (1st stack) (rest stack))))))) ; 220 1898 | ; 221 1899 | (define POP ; 222 1900 | (lambda simple [stack] ; 223 1901 | (if (empty stack) ; 224 1902 | (error 'stack-underflow) ; 225 1903 | (block1 (1st stack) ; 226 1904 | (rplact 0 stack (rest stack)))))) ; 227 1905 | ; 228 1906 | (define MACRO ; 229 1907 | (lambda simple [def-env pattern body] ; 230 1908 | (reflect def-env ; 231 1909 | `[,pattern env cont] ; 232 1910 | `(normalise ,body env cont)))) ; 233 1911 | ; 234 1912 | (define SMACRO ; 235 1913 | (lambda simple [def-env pattern body] ; 236 1914 | (reflect def-env ; 237 1915 | '[args env cont] ; 238 1916 | `(normalise args env ; 239 1917 | (lambda simple [,pattern] ; 240 1918 | (normalise ,body env cont)))))) ; 241 1919 | ; 242 1920 | ])) ; 243 1921 | ; Page 15:4 ; 244 1922 | (defun 3-define-utilities-2 () ; 245 1923 | (in-3-lisp \[ ; 246 1924 | ; 247 1925 | (define LET ; 248 1926 | (lambda macro [list body] ; 249 1927 | `((lambda simple ,(map 1st list) ,body) ; 250 1928 | .,(map 2nd list)))) ; 251 [illegible punctuation] 1929 | ; 252 1930 | (define LET* ; 253 1931 | (lambda macro [list body] ; 254 1932 | (if (empty list) ; 255 1933 | body ; 256 1934 | `((lambda simple ,(1st (1st list)) ; 257 1935 | ,(let* (rest list) body)) ; 258 1936 | .,(2nd (1st list)))))) ; 259 [illegible punctuation] 1937 | ; 260 1938 | (define SELECTQ ; 261 1939 | (lambda macro args ; 262 1940 | `(let [[select-key ,(1st args)]] ; 263 1941 | ,(selectq* (rest args))))) ; 264 1942 | ; 265 1943 | (define SELECTQ* ; 266 1944 | (lambda simple [cases] ; 267 1945 | (cond [(empty cases) `[]] ; 268 1946 | [(= (1st (1st cases)) '$T) ; 269 1947 | (2nd (1st cases))] ; 270 1948 | [$T `(if (= select-key ,↑(1st (1st cases))) ; 271 1949 | (block . ,(rest (1st cases))) ; 272 1950 | ,(selectq* (rest cases)))]))) ; 273 1951 | ; 274 1952 | (define SELECT ; 275 1953 | (lambda macro args ; 276 1954 | `(let [[select-key ,(1st args)]] ; 277 1955 | ,(select* (rest args))))) ; 278 1956 | ; 279 1957 | (define SELECT* ; 280 1958 | (lambda simple [cases] ; 281 1959 | (cond [(empty cases) `[]] ; 282 1960 | [(= (1st (1st cases)) '$T) ; 283 1961 | (2nd (1st cases))] ; 284 1962 | [$T `(if (= select-key ,(1st (1st cases))) ; 285 1963 | (block . ,(rest (1st cases))) ; 286 1964 | ,(select* (rest cases)))]))) ; 287 1965 | ; 288 1966 | (define BLOCK (lambda macro args (block* args))) ; 289 1967 | ; 290 1968 | (define BLOCK* ; 291 1969 | (lambda simple [args] ; 292 1970 | (cond [(empty args) (error 'too-few-args-to-block)] ; 293 1971 | [(unit args) (1st args)] ; 294 1972 | [$T `((lambda simple ? ; 295 1973 | ,(block* (rest args))) ; 296 1974 | ,(1st args))]))) ; 297 1975 | ; 298 1976 | (define COND (lambda macro args (cond* args))) ; 299 1977 | ; 300 1978 | (define COND* ; COND* cannot itself use COND ; 301 1979 | (lambda simple [args] ; 302 1980 | (if (empty args) `[] ; 303 1981 | `(if ,(1st (1st args)) ; 304 1982 | ,(2nd (1st args)) ; 305 1983 | ,(cond* (rest args)))))) ; 306 1984 | ; Page 15:5 ; 307 1985 | (define AND ; 308 1986 | (lambda macro args ; 309 1987 | (if (rail args) (and* args) `↓(and* ↑,args)))) ; 310 1988 | ; 311 1989 | (define AND* ; 312 1990 | (lambda simple [args] ; 313 1991 | (if (empty args) ; 314 1992 | '$T ; 315 1993 | `(if ,(1st args) ,(and* (rest args)) $F)))) ; 316 1994 | ; 317 1995 | (define OR ; 318 1996 | (lambda macro args ; 319 1997 | (if (rail args) (or* args) `↓(or* ↑,args)))) ; 320 1998 | ; 321 1999 | (define OR* ; 322 2000 | (lambda simple [args] ; 323 2001 | (if (empty args) '$F `(if ,(1st args) $T ,(or* (rest args)))))) ; 324 2002 | ; 325 2003 | (define MAP ; 326 2004 | (lambda simple args ; 327 2005 | (map* (1st args) (rest args)))) ; 328 2006 | ; 329 2007 | (define MAP* ; 330 2008 | (lambda simple [fun vectors] ; 331 2009 | (if (empty vectors) ; 332 2010 | (fun) ; 333 2011 | (if (empty (1st vectors)) ; 334 2012 | (1st vectors) ; 335 2013 | (prep (fun . (firsts vectors)) ; 336 2014 | (map* fun (rests vectors))))))) ; 337 2015 | ; 338 2016 | (define FIRSTS ; 339 2017 | (lambda simple [vectors] ; 340 2018 | (if (empty vectors) ; 341 2019 | vectors ; 342 2020 | (prep (1st (1st vectors)) ; 343 2021 | (firsts (rest vectors)))))) ; 344 2022 | ; 345 2023 | (define RESTS ; 346 2024 | (lambda simple [vectors] ; 347 2025 | (if (empty vectors) ; 348 2026 | vectors ; 349 2027 | (prep (rest (1st vectors)) ; 350 2028 | (rests (rest vectors)))))) ; 351 2029 | ; 352 2030 | (define PROTECTING ; 353 2031 | (lambda macro [names body] ; 354 2032 | `(let ,(protecting* names) ,body))) ; 355 2033 | ; 356 2034 | (define PROTECTING* ; 357 2035 | (lambda simple [names] ; 358 2036 | (if (empty names) ; 359 2037 | `[] ; 360 2038 | (prep `[,(1st names) ,(1st names)] ; 361 2039 | (protecting* (rest names)))))) ; 362 2040 | ])) ; 363 2041 | ; Page 15:6 ; 364 2042 | (defun 3-define-utilities-3 () ; 365 2043 | (in-3-lisp \[ ; 366 2044 | ; 367 2045 | (define REBIND ; 368 2046 | (lambda simple [var binding env] ; 369 2047 | (if (normal binding) ; 370 2048 | (rebind* var binding env) ; 371 2049 | (error 'binding-is-not-in-normal-form)))) ; 372 2050 | ; 373 2051 | (define REBIND* ; 374 2052 | (lambda simple [var binding env] ; 375 2053 | (cond [(empty env) (rplact 0 ↑env ↑[[var binding]])] ; 376 2054 | [(= var (1st (1st env))) ; 377 2055 | (rplacn 2 ↑(1st env) ↑binding)] ; 378 2056 | [$T (rebind* var binding (rest env))]))) ; 379 2057 | ; 380 2058 | (define SET ; 381 2059 | (lambda reflect [[var binding] env cont] ; 382 2060 | (normalise binding env ; 383 2061 | (lambda simple [binding*] ; 384 2062 | (cont (*rebind var binding* env)))))) ; 385 2063 | ; 386 2064 | (define DEFINE ; 387 2065 | (protecting [z] ; 388 2066 | (lambda macro [label form] ; 389 2067 | `(set ,label (,↑z (lambda simple [,label] ,form)))))) ; 390 2068 | ; 391 2069 | (define ERROR ; 392 2070 | (lambda reflect [a e c] ; 393 2071 | (undefined))) ; 394 2072 | ; 395 2073 | ])) ; 396 2074 | 2075 | ;; This is the end of the Appendix. 2076 | -------------------------------------------------------------------------------- /Procedural Reflection in Programming Languages.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nikitadanilov/3-lisp/ca2aed57483949f023531434620345d0066fca51/Procedural Reflection in Programming Languages.pdf -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 3-lisp: an infinite tower of meta-circular interpreters. 2 | 3 | 4 | 5 | [[Blog post](https://www.cofault.com/2022/08/3-lisp-infinite-tower-of-meta-circular.html)] 6 | 7 | ## Précis 8 | 3-lisp is a dialect of Lisp designed and implemented by [Brian C. Smith](https://en.wikipedia.org/wiki/Brian_Cantwell_Smith) 9 | as part of his PhD. thesis [Procedural Reflection in Programming Languages](https://dspace.mit.edu/handle/1721.1/15961) (what this thesis refers to as "[reflection](https://en.wikipedia.org/wiki/Reflective_programming)" 10 | is nowadays more usually called "[reification](https://en.wikipedia.org/wiki/Reification_(computer_science))"). A 3-lisp program is conceptually executed by an interpreter written in 3-lisp that is itself executed by an interpreter written in 3-lisp and so on *ad infinitum*. This forms a (countably) infinite tower of meta-circular (*v.i.*) interpreters. *reflective lambda* is a function that is executed one tower level above its caller. Reflective lambdas provide a very general language extension mechanism. 11 | 12 | This repository contains: 13 | 14 | - a copy of the thesis: [Procedural Reflection in Programming Languages.pdf](https://github.com/nikitadanilov/3-lisp/blob/master/Procedural%20Reflection%20in%20Programming%20Languages.pdf) 15 | - a transcript of the 3-lisp sources from the thesis appendix: [3-lisp.lisp](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp) 16 | - version of the sources ported to modern Common Lisp: [3-lisp.cl](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.cl) 17 | - some 3-lisp definitions from the thesis: [defs.3l](https://github.com/nikitadanilov/3-lisp/blob/master/defs.3l) 18 | 19 | ## Meta-circular interpreters 20 | An [interpreter](https://en.wikipedia.org/wiki/Interpreter_(computing)) is a 21 | program that executes programs written in some programming language. 22 | 23 | A [meta-circular interpreter](https://en.wikipedia.org/wiki/Meta-circular_evaluator) is an interpreter for a programming language written in that language. Meta-circular interpreters can be used to clarify or define the semantics of the language by reducing the full language to a sub-language in which the interpreter is expressed. Historically, such *definitional interpreters* become popular within the functional programming community, see the classical [Definitional interpreters for higher-order programming languages](https://surface.syr.edu/cgi/viewcontent.cgi?article=1012&context=lcsmith_other). Certain important techniques were classified and studied in the framework of meta-circular interpretation, for example, [continuation passing style](https://en.wikipedia.org/wiki/Continuation-passing_style) can be understood as a mechanism that makes meta-circular interpretation independent of the [evaluation strategy](https://en.wikipedia.org/wiki/Evaluation_strategy): it allows an eager meta-language to interpret a lazy object language and *vice versa*. As a by-product, a continuation passing style interpreter is essentially a state machine and so can be implemented in hardware, see [The Scheme-79 chip](https://dspace.mit.edu/handle/1721.1/6334). Similarly, *[de-functionalisation](https://www.brics.dk/RS/08/4/BRICS-RS-08-4.pdf)* of languages with higher-order functions obtains for them first-order interpreters. But meta-circular interpreters occur in imperative contexts too, for example, the usual proof of the [Böhm–Jacopini theorem](https://en.wikipedia.org/wiki/Structured_program_theorem) (interestingly, it was [Corrado Böhm](https://en.wikipedia.org/wiki/Corrado_B%C3%B6hm) who first introduced meta-circular interpreters in his 1954 PhD. thesis) constructs for an Algol-like language a meta-circular interpreter expressed in some goto-less subset of the language and then [specialises](https://en.wikipedia.org/wiki/Partial_evaluation) this interpreter for a particular program in the source language. 24 | 25 | Given a language with a meta-circular interpreter, suppose that the language is extended with a mechanism to *trap* to the meta-level. For example, in a lisp-like language, that trap can be a new special form `(reflect FORM)` that directly executes (rather than interprets) `FORM` within the interpreter. Smith is mostly interested in reflective (*i.e.*, reification) powers obtained this way, and it is clear that the meta-level trap provides a very general language extension method: one can add new primitives, data types, flow and sequencing control operators, *etc*. But if you try to add `reflect` to an existing LISP meta-circular interpreter (for example, see p. 13 of [LISP 1.5 Programmers Manual](https://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf)) you'd hit a problem: `FORM` cannot be executed at the meta-level, because at this level it is not a form, but an [S-expression](https://en.wikipedia.org/wiki/S-expression). 26 | 27 | ## Meta-interpreting machine code 28 | To understand the nature of the problem, consider a very simple case: the object language is the machine language (or equivalently the assembly language) of some processor. Suppose that the interpreter for the machine code is written in (or, more realistically, compiled to) the same machine language. The interpreter maintains the state of the simulated processor that is, among other things registers and memory. Say, the object (interpreted) code can access a register, `R0`, then the interpreter has to keep the contents of this register somewhere, but typically not in *its* (interpreter's) `R0`. Similarly, a memory word visible to the interpreted code at an address `ADDR` is stored by the interpreter at some, generally different, address `ADDR'` (although, by applying the [contractive mapping theorem](https://en.wikipedia.org/wiki/Banach_fixed-point_theorem) and a *lot* of hand-waving one might argue that there will be at least one word stored at the same address at the object- and meta-levels). Suppose that the interpreted machine language has the usual sub-routine call-return instructions `call ADDR` and `return` and is extended with a new instruction `reflect ADDR` that forces the interpreter to call the sub-routine `ADDR`. At the very least the interpreter needs to convert `ADDR` to the matching `ADDR'`. This might not be enough because, for example, the object-level sub-routine `ADDR` might not be contiguous at the meta-level, *i.e.*, it is not guaranteed that if `ADDR` maps to `ADDR'` then `(ADDR + 1)` maps `(ADDR' + 1)`. This example demonstrates that a reflective interpreter needs a systematic and efficient way of converting or translating between object- and meta-level representations. If such a method is somehow provided, `reflect` is a very powerful mechanism: by modifying interpreter state and code it can add new instructions, addressing modes, condition bits, branch predictors, *etc*. 29 | 30 | ## N-LISP for a suitable value of N 31 | In his thesis Prof. Smith analyses what would it take to construct a dialect of LISP for which a faithful reflective meta-circular interpreter is possible. He starts by defining a formal model of computation with an (extremely) rigorous distinction between meta- and object- levels (and, hence, between [use and mention](https://en.wikipedia.org/wiki/Use%E2%80%93mention_distinction)). It is then determined that this model can not be satisfactorily applied to the *traditional* LISP (which is called `1-LISP` in the thesis and is mostly based on [Maclisp](https://en.wikipedia.org/wiki/Maclisp)). The reason is that LISP's notion of [evaluation](https://en.wikipedia.org/wiki/Eval#Lisp) conflates two operations: [normalisation](https://en.wikipedia.org/wiki/Normal_form_(abstract_rewriting)) that operates within the level and [reference](https://en.wikipedia.org/wiki/Referent) that moves one level down. A dialect of LISP that consistently separates normalisation and reference is called `2-LISP` (the then new [Scheme](https://en.wikipedia.org/wiki/Scheme_(programming_language)) is called `LISP-1.75`). Definition of `2-LISP` occupies the bulk of the thesis, which the curious reader should consult for (exciting, believe me) details. 32 | 33 | Once `2-LISP` is constructed, adding the reflective capability to it is relatively straightforward. Meta-level trap takes the form of a special [lambda expression](https://en.wikipedia.org/wiki/Anonymous_function#Lisp): 34 | 35 | (lambda reflect [ARGS ENV CONT] BODY) 36 | 37 | When this lambda function is applied (at the object level), the body is directly executed (not interpreted) at the meta-level with `ARGS` bound to the meta-level representation of the actual parameters, `ENV` bound to the *environment* (basically, the list of identifiers and the values they are bound to) and `CONT` bound to the [continuation](https://en.wikipedia.org/wiki/Continuation). Environment and continuation together represent the `3-LISP` interpreter state (much like registers and memory represent the machine language interpreter state), this representation goes all the way back to [SECD machine](https://en.wikipedia.org/wiki/SECD_machine), see [The Mechanical Evaluation of Expressions](https://doi.org/10.1093%2Fcomjnl%2F6.4.308). 38 | 39 | Here is the fragment of `3-LISP` meta-circular interpreter code that handles `lambda reflect` (together with "ordinary" lambda-s, denoted by `lambda simple`): 40 | 41 | 42 | 43 | ## Implementation 44 | It is of course not possible to run an infinite tower of interpreters directly. 45 | 46 | 47 | 48 | `3-LISP` implementation creates a meta-level on demand, when a reflective lambda is invoked. At that moment the state of the meta-level interpreter is synthesised (*e.g.*, [see](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp#L1586) `make-c1` in the listing above). The implementation takes pain to detect when it can drop down to a lower level, which is not entirely simple because a reflective lambda can, instead of returning (that is, invoking the supplied continuation), run a potentially modified version of the [read-eval-loop](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop) (called `READ-NORMALISE-PRINT` ([see](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp#L1563)) in `3-LISP`) which does not return. There is a lot of non-trivial machinery operating behind the scenes and though the implementation modestly proclaims itself [EXTREMELY INEFFICIENT](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp#L33) it is, in fact, remarkably fast. 49 | 50 | ## Porting 51 | I was unable to find a digital copy of the `3-LISP` sources and so manually retyped the sources from the appendix of the thesis. The transcription in [3-lisp.lisp](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp) (2003 lines, 200K characters) preserves the original pagination and character set, see the comments at the top of the file. Transcription was mostly straightforward except for a few places where the PDF is illegible (for example, [here](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.lisp#L396)) all of which fortunately are within comment blocks. 52 | 53 | The sources are in [CADR machine](https://dspace.mit.edu/handle/1721.1/5718) dialect of LISP, which, save for some minimal and no longer relevant details, is equivalent to Maclisp. 54 | 55 | `3-LISP` implementation does not have its own parser or interpreter. Instead, it uses flexibility built in a lisp reader (see, [readtables](https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node192.html)) to parse, interpret and even compile `3-LISP` with a very small amount of additional code. Amazingly, this more than 40 years old code, which uses arcane features like readtable customisation, runs on a modern [Common Lisp](https://en.wikipedia.org/wiki/Common_Lisp) platform after a very small set of changes: some functions got renamed (`CASEQ` to `CASE`, `*CATCH` to `CATCH`, *etc*.), some functions are missing (`MEMQ`, `FIXP`), some signatures changed (`TYPEP`, `BREAK`, `IF`). See [3-lisp.cl](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.cl) for details. 56 | 57 | Unfortunately, the port does not run on *all* modern Common Lisp implementations, because it relies on the proper support for [backquotes](https://www.gnu.org/software/emacs/manual/html_node/elisp/Backquote.html) across recursive reader [invocations](https://github.com/nikitadanilov/3-lisp/blob/master/3-lisp.cl#L92): 58 | 59 | ;; Maclisp maintains backquote context across recursive parser 60 | ;; invocations. For example in the expression (which happens within defun 61 | ;; 3-EXPAND-PAIR) 62 | ;; 63 | ;; `\(PCONS ~,a ~,d) 64 | ;; 65 | ;; the backquote is consumed by the top-level activation of READ. Backslash 66 | ;; forces the switch to 3-lisp readtable and call to 3-READ to handle the 67 | ;; rest of the expression. Within this 3-READ activation, the tilde forces 68 | ;; switch back to L=READTABLE and a call to READ to handle ",a". In Maclisp, 69 | ;; this second READ activation re-uses the backquote context established by 70 | ;; the top-level READ activation. Of all Common Lisp implementations that I 71 | ;; tried, only sbcl correctly handles this situation. Lisp Works and clisp 72 | ;; complain about "comma outside of backquote". In clisp, 73 | ;; clisp-2.49/src/io.d:read_top() explicitly binds BACKQUOTE-LEVEL to nil. 74 | 75 | Among Common Lisp implementations I tried, only [sbcl](https://www.sbcl.org/) supports it properly. After reading Common Lisp [Hyperspec](http://www.lispworks.com/documentation/common-lisp.html), I believe that it is Maclisp and sbcl that implement the specification correctly and other implementations are faulty. 76 | 77 | ## Conclusion 78 | Procedural Reflection in Programming Languages is, in spite of its age, a very interesting read. Not only does it contain an implementation of a refreshingly new and bold idea (it is not even immediately obvious that infinite reflective towers can at all be implemented, not to say with any reasonable degree of efficiency), it is based on an interplay between mathematics and programming: the model of computation is proposed and afterward implemented in `3-LISP`. Because the model is implemented in an actual running program, it has to be specified with extreme precision (which would make [Tarski](https://en.wikipedia.org/wiki/Alfred_Tarski) and [Łukasiewicz](https://en.wikipedia.org/wiki/Jan_%C5%81ukasiewicz) tremble), and any execution of the `3-LISP` interpreter validates the model. 79 | 80 | -------------------------------------------------------------------------------- /defs.3l: -------------------------------------------------------------------------------- 1 | (define test1 (lambda reflect [args env cont] (return args))) ; (s5-66) 2 | (define test2 (lambda reflect [args env cont] (return env))) ; (s5-67) 3 | (define quit (lambda reflect ? 'quit!)) ; (s5-78) 4 | (define return (lambda reflect [[exp] env cont] (normalise exp env id))) ; (s5-80) 5 | (define up (lambda reflect [[arg] env cont] ; (s6-137) 6 | (normalise arg env 7 | (lambda simple [arg!] 8 | (if (= ↓arg! 1) 9 | (return 'ok) 10 | (up (- ↓arg! 1))))))) 11 | (define catch1 (lambda reflect [[arg] env cont] ; (s5-84) 12 | (cont (normalise arg env id)))) 13 | (define throw1 (lambda reflect [[arg] env cont] (normalise arg env id))) ; (s5-84) 14 | (define unwind-protect (lambda reflect [[form1] [form2] env cont] ; (s5-85) 15 | (cont (block1 (normalise form1 env id) 16 | (normalise form2 env id))))) 17 | (define block1 (lambda simple args (1st args))) ; (s5-86) 18 | (define catch2 (lambda reflect [[tag form] env cont] ; (s5-91) 19 | (let [[answer (normalise form env 20 | (lambda simple x x))]] 21 | (if (and (sequence answer) (= (length answer) 2)) 22 | (if (= (1st answer) tag) 23 | (cont (2nd answer)) 24 | answer) 25 | (cont . answer))))) 26 | (define throw2 (lambda reflect [[tag exp] env cont] ; (s5-91) 27 | (normalise exp env 28 | (lambda simple [exp!] [tag exp!])))) 29 | (define debug (lambda reflect [[message] env cont] ; (s5-166) 30 | (block (terpri) 31 | (print message) 32 | (cont (read-normalise-print env))))) 33 | 34 | (define factorial (lambda reflect [[n] env cont] 35 | (let [[n! (normalise n env id)]] 36 | (cont (if (= ↓n! 0) ↑1 ↑(* ↓n! (factorial (- ↓n! 1)))))))) 37 | --------------------------------------------------------------------------------