├── COPYING ├── README.md ├── doc ├── diff └── structures ├── lib.l ├── lib ├── debug.l ├── misc.l └── pilog.l ├── pil └── src ├── Makefile ├── apply.c ├── flow.c ├── gc.c ├── gen3m.c ├── init.s ├── io.c ├── lib.s ├── main.c ├── math.c ├── pico.h ├── pilog.s ├── subr.c └── sym.c /COPYING: -------------------------------------------------------------------------------- 1 | PicoLisp Copyright (c) Software Lab. Alexander Burger 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # miniPicoLisp 2 | A kind of "pure" PicoLisp (not "pure Lisp"!). 3 | 4 | https://software-lab.de/down.html 5 | 6 | For something even smaller, download miniPicoLisp.tgz. It is a minimal version, without support for databases, UTF-8, bignums, IPC, networking and other system-dependent functions. A kind of "pure" PicoLisp (not "pure Lisp"!). It supports the full PicoLisp language, but runs faster, and uses even less memory space. It should also not be restricted to Unix. In addition, it compiles and runs also on 64-bit systems. 7 | 8 | Jon Kleiser wrote an OpenGL library (native in the 64-bit version, or separate at gl.tgz for the 32-bit version), and a Chinese Checkers program running on top of it. 9 | 10 | Some philosophical and practical aspects are discussed in "A Radical Approach to Application Development (PDF)", and a description of PicoLisp DB and GUI Development principles is in "A Unifying Language for Database And User Interface Development". 11 | 12 | Please enjoy :-) 13 | 14 | -------------------------------------------------------------------------------- /doc/diff: -------------------------------------------------------------------------------- 1 | Differences to Standard PicoLisp 2 | ================================= 3 | 4 | Features 5 | No bignums (only 30- or 62-bit integers) 6 | No external symbols / database 7 | No unicode support (only ASCII subset) 8 | No binary I/O, family IPC, and networking 9 | No console line editing 10 | 11 | Semantics 12 | 'heap' and 'gc' in kB instead of MB 13 | -------------------------------------------------------------------------------- /doc/structures: -------------------------------------------------------------------------------- 1 | 2 | Primary data types: 3 | num xxxxxx10 4 | sym xxxxx100 5 | pair xxxxx000 6 | 7 | Raw data: 8 | bin xxxxxxxx 9 | txt xxxxxxx1 10 | 11 | 12 | num 13 | 14 | (30 bit) -536,870,912 .. +536,870,911 15 | 16 | (62 bit) -2,305,843,009,213,693,952 .. +2,305,843,009,213,693,951 17 | | | | | | | 18 | | | | | | Kilo 19 | | | | | Mega 20 | | | | Giga 21 | | | Tera 22 | | Peta 23 | Exa 24 | 25 | 26 | pair 27 | | 28 | V 29 | +-----+-----+ 30 | | car | cdr | 31 | +-----+-----+ 32 | 33 | 34 | sym sym 35 | | | 36 | V V 37 | +-----+-----+ +-----+-----+ 38 | | | | val | | txt | val | 39 | +--+--+-----+ +-----+-----+ 40 | | tail 41 | V 42 | +-----+-----+ +-----+-----+ 43 | | | | ---+---> | val | key | 44 | +--+--+-----+ +-----+-----+ 45 | | 46 | V 47 | +-----+-----+ 48 | | | | key | 49 | +--+--+-----+ 50 | | 51 | V 52 | +-----+-----+ +-----+-----+ 53 | | | | ---+---> | val | key | 54 | +--+--+-----+ +-----+-----+ 55 | | name 56 | V 57 | +-----+-----+ 58 | | bin | | | 59 | +-----+--+--+ 60 | | 61 | V 62 | +-----+-----+ 63 | | bin | | | 64 | +-----+--+--+ 65 | | 66 | V 67 | +-----+-----+ 68 | | bin | num | 69 | +-----+-----+ 70 | 71 | 72 | NIL: / 73 | | 74 | V 75 | +-----+-----+-----+-----+ 76 | |'NIL'| / | / | / | 77 | +-----+-----+-----+-----+ 78 | 79 | 80 | ASCII-6/7 -> 96 characters: 81 | xxxxx0 NUL sp ./<> a-z 82 | xxxxxx1 !"#$%&'()*+,- 0-9 :;=?@ A-Z [\]^_`{|}~ 83 | 84 | 85 | Assumptions: 86 | 87 | - 8 bits per byte 88 | - word: sizeof(void*) == sizeof(unsigned long) 89 | - gcc 90 | Functions aligned to 4-byte boundaries 91 | Conditionals with Omitted Operands 92 | Zero- or variable-length arrays 93 | Unused argument attributes 94 | Noreturn attributes 95 | -------------------------------------------------------------------------------- /lib.l: -------------------------------------------------------------------------------- 1 | # 06oct14abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | ### Symbol ### 5 | (de loc (S X) 6 | (if (and (str? X) (= S X)) 7 | X 8 | (and 9 | (pair X) 10 | (or 11 | (loc S (car X)) 12 | (loc S (cdr X)) ) ) ) ) 13 | 14 | ### Check ### 15 | # Unit tests 16 | (de test (Pat . Prg) 17 | (bind (fish pat? Pat) 18 | (unless (match Pat (run Prg 1)) 19 | (msg Prg) 20 | (quit 'fail Pat) ) ) ) 21 | 22 | ### Debug ### 23 | `*Dbg 24 | 25 | (de getd ("X") 26 | (and 27 | (sym? "X") 28 | (fun? (val "X")) 29 | (val "X") ) ) 30 | 31 | (de expr ("F") 32 | (set "F" 33 | (list '@ (list 'pass (box (getd "F")))) ) ) 34 | 35 | (de subr ("F") 36 | (set "F" 37 | (getd (cadr (cadr (getd "F")))) ) ) 38 | 39 | (load "@lib/debug.l") 40 | 41 | # vi:et:ts=3:sw=3 42 | -------------------------------------------------------------------------------- /lib/debug.l: -------------------------------------------------------------------------------- 1 | # 24nov16abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | # Browsing 5 | (de more ("M" "Fun") 6 | (let *Dbg NIL 7 | (if (pair "M") 8 | ((default "Fun" print) (++ "M")) 9 | (println (type "M")) 10 | (setq 11 | "Fun" (list '(X) (list 'pp 'X (lit "M"))) 12 | "M" (mapcar car (filter pair (val "M"))) ) ) 13 | (loop 14 | (flush) 15 | (T (atom "M") (prinl)) 16 | (T (line) T) 17 | ("Fun" (++ "M")) ) ) ) 18 | 19 | (de what (S) 20 | (let *Dbg NIL 21 | (setq S (chop S)) 22 | (filter 23 | '(("X") (match S (chop "X"))) 24 | (all) ) ) ) 25 | 26 | 27 | (de who ("X" . "*Prg") 28 | (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) 29 | (make (mapc "who" (all))) ) ) 30 | 31 | (de "who" ("Y") 32 | (unless (memq "Y" "Who") 33 | (push '"Who" "Y") 34 | (ifn (= `(char "+") (char "Y")) 35 | (and (pair (val "Y")) ("nest" @) (link "Y")) 36 | (for "Z" (pair (val "Y")) 37 | (if (atom "Z") 38 | (and ("match" "Z") (link "Y")) 39 | (when ("nest" (cdr "Z")) 40 | (link (cons (car "Z") "Y")) ) ) ) 41 | (maps 42 | '(("Z") 43 | (if (atom "Z") 44 | (and ("match" "Z") (link "Y")) 45 | (when ("nest" (car "Z")) 46 | (link (cons (cdr "Z") "Y")) ) ) ) 47 | "Y" ) ) ) ) 48 | 49 | (de "nest" ("Y") 50 | ("nst1" "Y") 51 | ("nst2" "Y") ) 52 | 53 | (de "nst1" ("Y") 54 | (let "Z" (setq "Y" (strip "Y")) 55 | (loop 56 | (T (atom "Y") (and (sym? "Y") ("who" "Y"))) 57 | (and (sym? (car "Y")) ("who" (car "Y"))) 58 | (and (pair (car "Y")) ("nst1" @)) 59 | (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 60 | 61 | (de "nst2" ("Y") 62 | (let "Z" (setq "Y" (strip "Y")) 63 | (loop 64 | (T (atom "Y") ("match" "Y")) 65 | (T (or ("match" (car "Y")) ("nst2" (car "Y"))) 66 | T ) 67 | (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) 68 | 69 | (de "match" ("D") 70 | (and 71 | (cond 72 | ((str? "X") (and (str? "D") (= "X" "D"))) 73 | ((sym? "X") (== "X" "D")) 74 | (T (match "X" "D")) ) 75 | (or 76 | (not "*Prg") 77 | (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) 78 | 79 | (de has ("X") 80 | (let *Dbg NIL 81 | (filter 82 | '(("S") (= "X" (val "S"))) 83 | (all) ) ) ) 84 | 85 | (de can (X) 86 | (let *Dbg NIL 87 | (extract 88 | '(("Y") 89 | (and 90 | (= `(char "+") (char "Y")) 91 | (asoq X (val "Y")) 92 | (cons X "Y") ) ) 93 | (all) ) ) ) 94 | 95 | # Class dependencies 96 | (de dep ("C") 97 | (let *Dbg NIL 98 | (dep1 0 "C") 99 | (dep2 3 "C") 100 | "C" ) ) 101 | 102 | (de dep1 (N "C") 103 | (for "X" (type "C") 104 | (dep1 (+ 3 N) "X") ) 105 | (space N) 106 | (println "C") ) 107 | 108 | (de dep2 (N "C") 109 | (for "X" (all) 110 | (when 111 | (and 112 | (= `(char "+") (char "X")) 113 | (memq "C" (type "X")) ) 114 | (space N) 115 | (println "X") 116 | (dep2 (+ 3 N) "X") ) ) ) 117 | 118 | # Inherited methods 119 | (de methods (Obj) 120 | (make 121 | (let Mark NIL 122 | (recur (Obj) 123 | (for X (val Obj) 124 | (nond 125 | ((pair X) (recurse X)) 126 | ((memq (car X) Mark) 127 | (link (cons (car X) Obj)) 128 | (push 'Mark (car X)) ) ) ) ) ) ) ) 129 | 130 | # Single-Stepping 131 | (de _dbg (Lst) 132 | (or 133 | (atom (car Lst)) 134 | (num? (caar Lst)) 135 | (flg? (caar Lst)) 136 | (== '! (caar Lst)) 137 | (set Lst (cons '! (car Lst))) ) ) 138 | 139 | (de _dbg2 (Lst) 140 | (map 141 | '((L) 142 | (if (and (pair (car L)) (flg? (caar L))) 143 | (map _dbg (cdar L)) 144 | (_dbg L) ) ) 145 | Lst ) ) 146 | 147 | (de dbg (Lst) 148 | (when (pair Lst) 149 | (casq (++ Lst) 150 | ((case casq state) 151 | (_dbg Lst) 152 | (for L (cdr Lst) 153 | (map _dbg (cdr L)) ) ) 154 | ((cond nond) 155 | (for L Lst 156 | (map _dbg L) ) ) 157 | (quote 158 | (when (fun? Lst) 159 | (map _dbg (cdr Lst)) ) ) 160 | ((job use let let? recur) 161 | (map _dbg (cdr Lst)) ) 162 | (loop 163 | (_dbg2 Lst) ) 164 | ((bind do) 165 | (_dbg Lst) 166 | (_dbg2 (cdr Lst)) ) 167 | (for 168 | (and (pair (car Lst)) (map _dbg (cdar Lst))) 169 | (_dbg2 (cdr Lst)) ) 170 | (T (map _dbg Lst)) ) 171 | T ) ) 172 | 173 | (de d () (let *Dbg NIL (dbg ^))) 174 | 175 | (de debug ("X" C) 176 | (ifn (traced? "X" C) 177 | (let *Dbg NIL 178 | (when (pair "X") 179 | (setq C (cdr "X") "X" (car "X")) ) 180 | (or 181 | (dbg (if C (method "X" C) (getd "X"))) 182 | (quit "Can't debug" "X") ) ) 183 | (untrace "X" C) 184 | (debug "X" C) 185 | (trace "X" C) ) ) 186 | 187 | (de ubg (Lst) 188 | (when (pair Lst) 189 | (map 190 | '((L) 191 | (when (pair (car L)) 192 | (when (== '! (caar L)) 193 | (set L (cdar L)) ) 194 | (ubg (car L)) ) ) 195 | Lst ) 196 | T ) ) 197 | 198 | (de u () (let *Dbg NIL (ubg ^))) 199 | 200 | (de unbug ("X" C) 201 | (let *Dbg NIL 202 | (when (pair "X") 203 | (setq C (cdr "X") "X" (car "X")) ) 204 | (or 205 | (ubg (if C (method "X" C) (getd "X"))) 206 | (quit "Can't unbug" "X") ) ) ) 207 | 208 | # Tracing 209 | (de traced? ("X" C) 210 | (setq "X" 211 | (if C 212 | (method "X" C) 213 | (getd "X") ) ) 214 | (and 215 | (pair "X") 216 | (pair (cadr "X")) 217 | (== '$ (caadr "X")) ) ) 218 | 219 | # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) 220 | (de trace ("X" C) 221 | (let *Dbg NIL 222 | (when (pair "X") 223 | (setq C (cdr "X") "X" (car "X")) ) 224 | (if C 225 | (unless (traced? "X" C) 226 | (or (method "X" C) (quit "Can't trace" "X")) 227 | (con @ 228 | (cons 229 | (conc 230 | (list '$ (cons "X" C) (car @)) 231 | (cdr @) ) ) ) ) 232 | (unless (traced? "X") 233 | (and (sym? (getd "X")) (quit "Can't trace" "X")) 234 | (and (num? (getd "X")) (expr "X")) 235 | (set "X" 236 | (list 237 | (car (getd "X")) 238 | (conc (list '$ "X") (getd "X")) ) ) ) ) 239 | "X" ) ) 240 | 241 | # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) 242 | (de untrace ("X" C) 243 | (let *Dbg NIL 244 | (when (pair "X") 245 | (setq C (cdr "X") "X" (car "X")) ) 246 | (if C 247 | (when (traced? "X" C) 248 | (con 249 | (method "X" C) 250 | (cdddr (cadr (method "X" C))) ) ) 251 | (when (traced? "X") 252 | (let X (set "X" (cddr (cadr (getd "X")))) 253 | (and 254 | (== '@ (++ X)) 255 | (= 1 (length X)) 256 | (= 2 (length (car X))) 257 | (== 'pass (caar X)) 258 | (sym? (cdadr X)) 259 | (subr "X") ) ) ) ) 260 | "X" ) ) 261 | 262 | (de *NoTrace 263 | @ @@ @@@ 264 | pp show more led 265 | what who can dep d e debug u unbug trace untrace ) 266 | 267 | (de traceAll (Excl) 268 | (let *Dbg NIL 269 | (for "X" (all) 270 | (or 271 | (memq "X" Excl) 272 | (memq "X" *NoTrace) 273 | (= `(char "*") (char "X")) 274 | (cond 275 | ((= `(char "+") (char "X")) 276 | (mapc trace 277 | (extract 278 | '(("Y") 279 | (and 280 | (pair "Y") 281 | (fun? (cdr "Y")) 282 | (cons (car "Y") "X") ) ) 283 | (val "X") ) ) ) 284 | ((pair (getd "X")) 285 | (trace "X") ) ) ) ) ) ) 286 | 287 | # vi:et:ts=3:sw=3 288 | -------------------------------------------------------------------------------- /lib/misc.l: -------------------------------------------------------------------------------- 1 | # 24nov16abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | ### Math ### 5 | (de accu (Var Key Val) 6 | (when Val 7 | (if (assoc Key (val Var)) 8 | (con @ (+ Val (cdr @))) 9 | (push Var (cons Key Val)) ) ) ) 10 | 11 | ### String ### 12 | (de align (X . @) 13 | (pack 14 | (if (pair X) 15 | (mapcar 16 | '((X) (need X (chop (next)) " ")) 17 | X ) 18 | (need X (chop (next)) " ") ) ) ) 19 | 20 | ### Number ### 21 | (de pad (N Val) 22 | (pack (need N (chop Val) "0")) ) 23 | 24 | (de hex (X I) 25 | (cond 26 | ((num? X) 27 | (let (S (and (lt0 X) '-) L (hex1 X) A (cons 0 I)) 28 | (until (=0 (setq X (>> 4 X))) 29 | (at A (push 'L " ")) 30 | (push 'L (hex1 X)) ) 31 | (pack S L) ) ) 32 | ((setq X (filter '((C) (not (sp? C))) (chop X))) 33 | (let (S (and (= '- (car X)) (++ X)) N 0) 34 | (for C X 35 | (setq C (- (char C) `(char "0"))) 36 | (and (> C 9) (dec 'C 7)) 37 | (and (> C 22) (dec 'C 32)) 38 | (setq N (| C (>> -4 N))) ) 39 | (if S (- N) N) ) ) ) ) 40 | 41 | (de hex1 (N) 42 | (let C (& 15 N) 43 | (and (> C 9) (inc 'C 7)) 44 | (char (+ C `(char "0"))) ) ) 45 | 46 | ### Tree ### 47 | (de balance ("Var" "Lst" "Flg") 48 | (unless "Flg" (set "Var")) 49 | (let "Len" (length "Lst") 50 | (recur ("Lst" "Len") 51 | (unless (=0 "Len") 52 | (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) 53 | (idx "Var" (car "L") T) 54 | (recurse "Lst" (dec "N")) 55 | (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) 56 | 57 | (de depth (Idx) #> (max . average) 58 | (let (C 0 D 0 N 0) 59 | (cons 60 | (recur (Idx N) 61 | (ifn Idx 62 | 0 63 | (inc 'C) 64 | (inc 'D (inc 'N)) 65 | (inc 66 | (max 67 | (recurse (cadr Idx) N) 68 | (recurse (cddr Idx) N) ) ) ) ) 69 | (or (=0 (setq @@ C)) (*/ D C)) ) ) ) 70 | 71 | ### Date ### 72 | (de dat$ (Dat C) 73 | (when (date Dat) 74 | (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) 75 | 76 | (de $dat (S C) 77 | (if C 78 | (and 79 | (= 3 80 | (length (setq S (split (chop S) C))) ) 81 | (date 82 | (format (pack (car S))) # Year 83 | (or (format (pack (cadr S))) 0) # Month 84 | (or (format (pack (caddr S))) 0) ) ) # Day 85 | (and 86 | (format S) 87 | (date 88 | (/ @ 10000) # Year 89 | (% (/ @ 100) 100) # Month 90 | (% @ 100) ) ) ) ) 91 | 92 | # vi:et:ts=3:sw=3 93 | -------------------------------------------------------------------------------- /lib/pilog.l: -------------------------------------------------------------------------------- 1 | # 24nov16abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | # *Rule 5 | 6 | (de be CL 7 | (clause CL) ) 8 | 9 | (de clause (CL) 10 | (with (car CL) 11 | (if (== *Rule This) 12 | (queue (:: T) (cdr CL)) 13 | (=: T (cons (cdr CL))) 14 | (setq *Rule This) ) 15 | This ) ) 16 | 17 | (de repeat () 18 | (conc (get *Rule T) (get *Rule T)) ) 19 | 20 | (de asserta (CL) 21 | (push (prop CL 1 T) (cdr CL)) ) 22 | 23 | (de assertz (CL) 24 | (queue (prop CL 1 T) (cdr CL)) ) 25 | 26 | (de retract (X) 27 | (if (sym? X) 28 | (put X T) 29 | (put (car X) T 30 | (delete (cdr X) (get (car X) T)) ) ) ) 31 | 32 | (de rules @ 33 | (while (args) 34 | (let S (next) 35 | (for ((N . L) (get S T) L) 36 | (prin N " (be ") 37 | (print S) 38 | (for X (++ L) 39 | (space) 40 | (print X) ) 41 | (prinl ")") 42 | (T (== L (get S T)) 43 | (println '(repeat)) ) ) 44 | S ) ) ) 45 | 46 | ### Pilog Interpreter ### 47 | (de goal ("CL" . @) 48 | (let "Env" '(T) 49 | (while (args) 50 | (push '"Env" 51 | (cons (cons 0 (next)) 1 (next)) ) ) 52 | (while (and "CL" (pat? (car "CL"))) 53 | (push '"Env" 54 | (cons 55 | (cons 0 (++ "CL")) 56 | (cons 1 (eval (++ "CL"))) ) ) ) 57 | (cons 58 | (cons 59 | (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) 60 | 61 | (de fail () 62 | (goal '((NIL))) ) 63 | 64 | (de pilog ("CL" . "Prg") 65 | (for ("Q" (goal "CL") (prove "Q")) 66 | (bind @ (run "Prg")) ) ) 67 | 68 | (de solve ("CL" . "Prg") 69 | (make 70 | (if "Prg" 71 | (for ("Q" (goal "CL") (prove "Q")) 72 | (link (bind @ (run "Prg"))) ) 73 | (for ("Q" (goal "CL") (prove "Q")) 74 | (link @) ) ) ) ) 75 | 76 | (de query ("Q" "Dbg") 77 | (use "R" 78 | (loop 79 | (NIL (prove "Q" "Dbg")) 80 | (T (=T (setq "R" @)) T) 81 | (for X "R" 82 | (space) 83 | (print (car X)) 84 | (print '=) 85 | (print (cdr X)) 86 | (flush) ) 87 | (T (line)) ) ) ) 88 | 89 | (de ? "CL" 90 | (let "L" 91 | (make 92 | (while (nor (pat? (car "CL")) (lst? (car "CL"))) 93 | (link (++ "CL")) ) ) 94 | (query (goal "CL") "L") ) ) 95 | 96 | ### Basic Rules ### 97 | (be repeat) 98 | (repeat) 99 | 100 | (be true) 101 | 102 | (be not @P (1 (-> @P)) T (fail)) 103 | (be not @P) 104 | 105 | (be call @P 106 | (2 (cons (-> @P))) ) 107 | 108 | (be or @L (^ @C (box (-> @L))) (_or @C)) 109 | 110 | (be _or (@C) (3 (pop (-> @C)))) 111 | (be _or (@C) (^ @ (not (val (-> @C)))) T (fail)) 112 | (repeat) 113 | 114 | (be nil (@X) (^ @ (not (-> @X)))) 115 | 116 | (be equal (@X @X)) 117 | 118 | (be different (@X @X) T (fail)) 119 | (be different (@ @)) 120 | 121 | (be append (NIL @X @X)) 122 | (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) 123 | 124 | (be member (@X (@X . @))) 125 | (be member (@X (@ . @Y)) (member @X @Y)) 126 | 127 | (be delete (@A (@A . @Z) @Z)) 128 | (be delete (@A (@X . @Y) (@X . @Z)) 129 | (delete @A @Y @Z) ) 130 | 131 | (be permute ((@X) (@X))) 132 | (be permute (@L (@X . @Y)) 133 | (delete @X @L @D) 134 | (permute @D @Y) ) 135 | 136 | (be uniq (@B @X) 137 | (^ @ (not (idx (-> @B) (-> @X) T))) ) 138 | 139 | (be asserta (@C) (^ @ (asserta (-> @C)))) 140 | 141 | (be assertz (@C) (^ @ (assertz (-> @C)))) 142 | 143 | (be retract (@C) 144 | (2 (cons (-> @C))) 145 | (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) ) 146 | 147 | (be clause ("@H" "@B") 148 | (^ "@A" (get (-> "@H") T)) 149 | (member "@B" "@A") ) 150 | 151 | (be show (@X) (^ @ (show (-> @X)))) 152 | 153 | (be for (@N @End) (for @N 1 @End 1)) 154 | (be for (@N @Beg @End) (for @N @Beg @End 1)) 155 | (be for (@N @Beg @End @Step) (equal @N @Beg)) 156 | (be for (@N @Beg @End @Step) 157 | (^ @I (box (-> @Beg))) 158 | (_for @N @I @End @Step) ) 159 | 160 | (be _for (@N @I @End @Step) 161 | (^ @ 162 | (if (>= (-> @End) (val (-> @I))) 163 | (> (inc (-> @I) (-> @Step)) (-> @End)) 164 | (> (-> @End) (dec (-> @I) (-> @Step))) ) ) 165 | T 166 | (fail) ) 167 | 168 | (be _for (@N @I @End @Step) 169 | (^ @N (val (-> @I))) ) 170 | 171 | (repeat) 172 | 173 | (be val (@V . @L) 174 | (^ @V (apply get (-> @L))) 175 | T ) 176 | 177 | (be lst (@V . @L) 178 | (^ @Lst (box (apply get (-> @L)))) 179 | (_lst @V @Lst) ) 180 | 181 | (be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) 182 | (be _lst (@Val @Lst) (^ @Val (pop (-> @Lst)))) 183 | (repeat) 184 | 185 | (be map (@V . @L) 186 | (^ @Lst (box (apply get (-> @L)))) 187 | (_map @V @Lst) ) 188 | 189 | (be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) 190 | (be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst))))) 191 | (repeat) 192 | 193 | # vi:et:ts=3:sw=3 194 | -------------------------------------------------------------------------------- /pil: -------------------------------------------------------------------------------- 1 | exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @lib/misc.l "$@" 2 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # 12dec16abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | .SILENT: 5 | 6 | bin = ../bin 7 | picoFiles = main.c gc.c apply.c flow.c sym.c subr.c math.c io.c 8 | 9 | CC = gcc 10 | 11 | picolisp: $(bin)/picolisp 12 | 13 | .c.o: 14 | echo $*.c: 15 | $(CC) -c -O2 -pipe \ 16 | -falign-functions -fomit-frame-pointer -fno-strict-aliasing \ 17 | -W -Wimplicit -Wreturn-type -Wunused -Wformat \ 18 | -Wuninitialized -Wstrict-prototypes \ 19 | -D_GNU_SOURCE $*.c 20 | 21 | $(bin)/picolisp: $(picoFiles:.c=.o) 22 | mkdir -p $(bin) 23 | echo " " link picolisp: 24 | $(CC) -o $(bin)/picolisp $(picoFiles:.c=.o) -lc -lm 25 | strip $(bin)/picolisp 26 | 27 | $(picoFiles:.c=.o): pico.h sym.d rom.d ram.d 28 | 29 | sym.d rom.d ram.d: gen3m init.s lib.s pilog.s 30 | ./gen3m 0 init.s lib.s pilog.s 31 | 32 | gen3m: gen3m.c 33 | $(CC) -o gen3m gen3m.c 34 | 35 | # Clean up 36 | clean: 37 | rm -f gen3m *.d *.o 38 | 39 | # vi:noet:ts=4:sw=4 40 | -------------------------------------------------------------------------------- /src/apply.c: -------------------------------------------------------------------------------- 1 | /* 25mar14abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | any apply(any ex, any foo, bool cf, int n, cell *p) { 8 | while (!isNum(foo)) { 9 | if (isCell(foo)) { 10 | int i; 11 | any x = car(foo); 12 | struct { // bindFrame 13 | struct bindFrame *link; 14 | int i, cnt; 15 | struct {any sym; any val;} bnd[length(x)+2]; 16 | } f; 17 | 18 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 19 | f.i = 0; 20 | f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 21 | while (isCell(x)) { 22 | f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 23 | val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); 24 | ++f.cnt, x = cdr(x); 25 | } 26 | if (isNil(x)) 27 | x = prog(cdr(foo)); 28 | else if (x != At) { 29 | f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; 30 | while (--n >= 0) 31 | val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), 0), val(x)); 32 | ++f.cnt; 33 | x = prog(cdr(foo)); 34 | } 35 | else { 36 | int cnt = n; 37 | int next = Env.next; 38 | cell *arg = Env.arg; 39 | cell c[Env.next = n]; 40 | 41 | Env.arg = c; 42 | for (i = f.cnt-1; --n >= 0; ++i) 43 | Push(c[n], cf? car(data(p[i])) : data(p[i])); 44 | x = prog(cdr(foo)); 45 | if (cnt) 46 | drop(c[cnt-1]); 47 | Env.arg = arg, Env.next = next; 48 | } 49 | while (--f.cnt >= 0) 50 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 51 | Env.bind = f.link; 52 | return x; 53 | } 54 | if (val(foo) == val(Meth)) { 55 | any expr, o, x; 56 | 57 | o = cf? car(data(p[0])) : data(p[0]); 58 | NeedSymb(ex,o); 59 | TheCls = NULL, TheKey = foo; 60 | if (expr = method(o)) { 61 | int i; 62 | any cls = Env.cls, key = Env.key; 63 | struct { // bindFrame 64 | struct bindFrame *link; 65 | int i, cnt; 66 | struct {any sym; any val;} bnd[length(x = car(expr))+3]; 67 | } f; 68 | 69 | Env.cls = TheCls, Env.key = TheKey; 70 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 71 | f.i = 0; 72 | f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 73 | --n, ++p; 74 | while (isCell(x)) { 75 | f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 76 | val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); 77 | ++f.cnt, x = cdr(x); 78 | } 79 | if (isNil(x)) { 80 | f.bnd[f.cnt].sym = This; 81 | f.bnd[f.cnt++].val = val(This); 82 | val(This) = o; 83 | x = prog(cdr(expr)); 84 | } 85 | else if (x != At) { 86 | f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; 87 | while (--n >= 0) 88 | val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), 0), val(x)); 89 | ++f.cnt; 90 | f.bnd[f.cnt].sym = This; 91 | f.bnd[f.cnt++].val = val(This); 92 | val(This) = o; 93 | x = prog(cdr(expr)); 94 | } 95 | else { 96 | int cnt = n; 97 | int next = Env.next; 98 | cell *arg = Env.arg; 99 | cell c[Env.next = n]; 100 | 101 | Env.arg = c; 102 | for (i = f.cnt-1; --n >= 0; ++i) 103 | Push(c[n], cf? car(data(p[i])) : data(p[i])); 104 | f.bnd[f.cnt].sym = This; 105 | f.bnd[f.cnt++].val = val(This); 106 | val(This) = o; 107 | x = prog(cdr(expr)); 108 | if (cnt) 109 | drop(c[cnt-1]); 110 | Env.arg = arg, Env.next = next; 111 | } 112 | while (--f.cnt >= 0) 113 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 114 | Env.bind = f.link; 115 | Env.cls = cls, Env.key = key; 116 | return x; 117 | } 118 | err(ex, o, "Bad object"); 119 | } 120 | if (isNil(val(foo)) || foo == val(foo)) 121 | undefined(foo,ex); 122 | foo = val(foo); 123 | } 124 | if (--n < 0) 125 | cdr(ApplyBody) = Nil; 126 | else { 127 | any x = ApplyArgs; 128 | val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 129 | while (--n >= 0) { 130 | if (!isCell(cdr(x))) 131 | cdr(x) = cons(cons(consSym(Nil,0), car(x)), Nil); 132 | x = cdr(x); 133 | val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 134 | } 135 | cdr(ApplyBody) = car(x); 136 | } 137 | return evSubr(foo, ApplyBody); 138 | } 139 | 140 | // (apply 'fun 'lst ['any ..]) -> any 141 | any doApply(any ex) { 142 | any x, y; 143 | int i, n; 144 | cell foo; 145 | 146 | x = cdr(ex), Push(foo, EVAL(car(x))); 147 | x = cdr(x), y = EVAL(car(x)); 148 | { 149 | cell c[(n = length(cdr(x))) + length(y)]; 150 | 151 | while (isCell(y)) 152 | Push(c[n], car(y)), y = cdr(y), ++n; 153 | for (i = 0; isCell(x = cdr(x)); ++i) 154 | Push(c[i], EVAL(car(x))); 155 | x = apply(ex, data(foo), NO, n, c); 156 | } 157 | drop(foo); 158 | return x; 159 | } 160 | 161 | // (pass 'fun ['any ..]) -> any 162 | any doPass(any ex) { 163 | any x; 164 | int n, i; 165 | cell foo, c[length(cdr(x = cdr(ex))) + (Env.next>0? Env.next : 0)]; 166 | 167 | Push(foo, EVAL(car(x))); 168 | for (n = 0; isCell(x = cdr(x)); ++n) 169 | Push(c[n], EVAL(car(x))); 170 | for (i = Env.next; --i >= 0; ++n) 171 | Push(c[n], data(Env.arg[i])); 172 | x = apply(ex, data(foo), NO, n, c); 173 | drop(foo); 174 | return x; 175 | } 176 | 177 | // (maps 'fun 'sym ['lst ..]) -> any 178 | any doMaps(any ex) { 179 | any x, y; 180 | int i, n; 181 | cell foo, sym, val, c[length(cdr(x = cdr(ex)))]; 182 | 183 | Push(foo, EVAL(car(x))); 184 | x = cdr(x), Push(sym, EVAL(car(x))); 185 | NeedSymb(ex, data(sym)); 186 | for (n = 1; isCell(x = cdr(x)); ++n) 187 | Push(c[n], EVAL(car(x))); 188 | data(c[0]) = &val; 189 | for (y = tail(data(sym)); isCell(y); y = car(y)) { 190 | data(val) = cdr(y); 191 | x = apply(ex, data(foo), YES, n, c); 192 | for (i = 1; i < n; ++i) 193 | data(c[i]) = cdr(data(c[i])); 194 | } 195 | drop(foo); 196 | return x; 197 | } 198 | 199 | // (map 'fun 'lst ..) -> lst 200 | any doMap(any ex) { 201 | any x = cdr(ex); 202 | cell foo; 203 | 204 | Push(foo, EVAL(car(x))); 205 | if (isCell(x = cdr(x))) { 206 | int i, n = 0; 207 | cell c[length(x)]; 208 | 209 | do 210 | Push(c[n], EVAL(car(x))), ++n; 211 | while (isCell(x = cdr(x))); 212 | while (isCell(data(c[0]))) { 213 | x = apply(ex, data(foo), NO, n, c); 214 | for (i = 0; i < n; ++i) 215 | data(c[i]) = cdr(data(c[i])); 216 | } 217 | } 218 | drop(foo); 219 | return x; 220 | } 221 | 222 | // (mapc 'fun 'lst ..) -> any 223 | any doMapc(any ex) { 224 | any x = cdr(ex); 225 | cell foo; 226 | 227 | Push(foo, EVAL(car(x))); 228 | if (isCell(x = cdr(x))) { 229 | int i, n = 0; 230 | cell c[length(x)]; 231 | 232 | do 233 | Push(c[n], EVAL(car(x))), ++n; 234 | while (isCell(x = cdr(x))); 235 | while (isCell(data(c[0]))) { 236 | x = apply(ex, data(foo), YES, n, c); 237 | for (i = 0; i < n; ++i) 238 | data(c[i]) = cdr(data(c[i])); 239 | } 240 | } 241 | drop(foo); 242 | return x; 243 | } 244 | 245 | // (maplist 'fun 'lst ..) -> lst 246 | any doMaplist(any ex) { 247 | any x = cdr(ex); 248 | cell res, foo; 249 | 250 | Push(res, Nil); 251 | Push(foo, EVAL(car(x))); 252 | if (isCell(x = cdr(x))) { 253 | int i, n = 0; 254 | cell c[length(x)]; 255 | 256 | do 257 | Push(c[n], EVAL(car(x))), ++n; 258 | while (isCell(x = cdr(x))); 259 | if (!isCell(data(c[0]))) 260 | return Pop(res); 261 | data(res) = x = cons(apply(ex, data(foo), NO, n, c), Nil); 262 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 263 | for (i = 1; i < n; ++i) 264 | data(c[i]) = cdr(data(c[i])); 265 | cdr(x) = cons(apply(ex, data(foo), NO, n, c), Nil); 266 | x = cdr(x); 267 | } 268 | } 269 | return Pop(res); 270 | } 271 | 272 | // (mapcar 'fun 'lst ..) -> lst 273 | any doMapcar(any ex) { 274 | any x = cdr(ex); 275 | cell res, foo; 276 | 277 | Push(res, Nil); 278 | Push(foo, EVAL(car(x))); 279 | if (isCell(x = cdr(x))) { 280 | int i, n = 0; 281 | cell c[length(x)]; 282 | 283 | do 284 | Push(c[n], EVAL(car(x))), ++n; 285 | while (isCell(x = cdr(x))); 286 | if (!isCell(data(c[0]))) 287 | return Pop(res); 288 | data(res) = x = cons(apply(ex, data(foo), YES, n, c), Nil); 289 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 290 | for (i = 1; i < n; ++i) 291 | data(c[i]) = cdr(data(c[i])); 292 | cdr(x) = cons(apply(ex, data(foo), YES, n, c), Nil); 293 | x = cdr(x); 294 | } 295 | } 296 | return Pop(res); 297 | } 298 | 299 | // (mapcon 'fun 'lst ..) -> lst 300 | any doMapcon(any ex) { 301 | any x = cdr(ex); 302 | cell res, foo; 303 | 304 | Push(res, Nil); 305 | Push(foo, EVAL(car(x))); 306 | if (isCell(x = cdr(x))) { 307 | int i, n = 0; 308 | cell c[length(x)]; 309 | 310 | do 311 | Push(c[n], EVAL(car(x))), ++n; 312 | while (isCell(x = cdr(x))); 313 | if (!isCell(data(c[0]))) 314 | return Pop(res); 315 | while (!isCell(x = apply(ex, data(foo), NO, n, c))) { 316 | if (!isCell(data(c[0]) = cdr(data(c[0])))) 317 | return Pop(res); 318 | for (i = 1; i < n; ++i) 319 | data(c[i]) = cdr(data(c[i])); 320 | } 321 | data(res) = x; 322 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 323 | for (i = 1; i < n; ++i) 324 | data(c[i]) = cdr(data(c[i])); 325 | while (isCell(cdr(x))) 326 | x = cdr(x); 327 | cdr(x) = apply(ex, data(foo), NO, n, c); 328 | } 329 | } 330 | return Pop(res); 331 | } 332 | 333 | // (mapcan 'fun 'lst ..) -> lst 334 | any doMapcan(any ex) { 335 | any x = cdr(ex); 336 | cell res, foo; 337 | 338 | Push(res, Nil); 339 | Push(foo, EVAL(car(x))); 340 | if (isCell(x = cdr(x))) { 341 | int i, n = 0; 342 | cell c[length(x)]; 343 | 344 | do 345 | Push(c[n], EVAL(car(x))), ++n; 346 | while (isCell(x = cdr(x))); 347 | if (!isCell(data(c[0]))) 348 | return Pop(res); 349 | while (!isCell(x = apply(ex, data(foo), YES, n, c))) { 350 | if (!isCell(data(c[0]) = cdr(data(c[0])))) 351 | return Pop(res); 352 | for (i = 1; i < n; ++i) 353 | data(c[i]) = cdr(data(c[i])); 354 | } 355 | data(res) = x; 356 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 357 | for (i = 1; i < n; ++i) 358 | data(c[i]) = cdr(data(c[i])); 359 | while (isCell(cdr(x))) 360 | x = cdr(x); 361 | cdr(x) = apply(ex, data(foo), YES, n, c); 362 | } 363 | } 364 | return Pop(res); 365 | } 366 | 367 | // (filter 'fun 'lst ..) -> lst 368 | any doFilter(any ex) { 369 | any x = cdr(ex); 370 | cell res, foo; 371 | 372 | Push(res, Nil); 373 | Push(foo, EVAL(car(x))); 374 | if (isCell(x = cdr(x))) { 375 | int i, n = 0; 376 | cell c[length(x)]; 377 | 378 | do 379 | Push(c[n], EVAL(car(x))), ++n; 380 | while (isCell(x = cdr(x))); 381 | if (!isCell(data(c[0]))) 382 | return Pop(res); 383 | while (isNil(apply(ex, data(foo), YES, n, c))) { 384 | if (!isCell(data(c[0]) = cdr(data(c[0])))) 385 | return Pop(res); 386 | for (i = 1; i < n; ++i) 387 | data(c[i]) = cdr(data(c[i])); 388 | } 389 | data(res) = x = cons(car(data(c[0])), Nil); 390 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 391 | for (i = 1; i < n; ++i) 392 | data(c[i]) = cdr(data(c[i])); 393 | if (!isNil(apply(ex, data(foo), YES, n, c))) 394 | x = cdr(x) = cons(car(data(c[0])), Nil); 395 | } 396 | } 397 | return Pop(res); 398 | } 399 | 400 | // (extract 'fun 'lst ..) -> lst 401 | any doExtract(any ex) { 402 | any x = cdr(ex); 403 | any y; 404 | cell res, foo; 405 | 406 | Push(res, Nil); 407 | Push(foo, EVAL(car(x))); 408 | if (isCell(x = cdr(x))) { 409 | int i, n = 0; 410 | cell c[length(x)]; 411 | 412 | do 413 | Push(c[n], EVAL(car(x))), ++n; 414 | while (isCell(x = cdr(x))); 415 | if (!isCell(data(c[0]))) 416 | return Pop(res); 417 | while (isNil(y = apply(ex, data(foo), YES, n, c))) { 418 | if (!isCell(data(c[0]) = cdr(data(c[0])))) 419 | return Pop(res); 420 | for (i = 1; i < n; ++i) 421 | data(c[i]) = cdr(data(c[i])); 422 | } 423 | data(res) = x = cons(y, Nil); 424 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 425 | for (i = 1; i < n; ++i) 426 | data(c[i]) = cdr(data(c[i])); 427 | if (!isNil(y = apply(ex, data(foo), YES, n, c))) 428 | x = cdr(x) = cons(y, Nil); 429 | } 430 | } 431 | return Pop(res); 432 | } 433 | 434 | // (seek 'fun 'lst ..) -> lst 435 | any doSeek(any ex) { 436 | any x = cdr(ex); 437 | cell foo; 438 | 439 | Push(foo, EVAL(car(x))); 440 | if (isCell(x = cdr(x))) { 441 | int i, n = 0; 442 | cell c[length(x)]; 443 | 444 | do 445 | Push(c[n], EVAL(car(x))), ++n; 446 | while (isCell(x = cdr(x))); 447 | while (isCell(data(c[0]))) { 448 | if (!isNil(x = apply(ex, data(foo), NO, n, c))) { 449 | drop(foo); 450 | val(At2) = x; 451 | return data(c[0]); 452 | } 453 | for (i = 0; i < n; ++i) 454 | data(c[i]) = cdr(data(c[i])); 455 | } 456 | } 457 | drop(foo); 458 | return Nil; 459 | } 460 | 461 | // (find 'fun 'lst ..) -> any 462 | any doFind(any ex) { 463 | any x = cdr(ex); 464 | cell foo; 465 | 466 | Push(foo, EVAL(car(x))); 467 | if (isCell(x = cdr(x))) { 468 | int i, n = 0; 469 | cell c[length(x)]; 470 | 471 | do 472 | Push(c[n], EVAL(car(x))), ++n; 473 | while (isCell(x = cdr(x))); 474 | while (isCell(data(c[0]))) { 475 | if (!isNil(x = apply(ex, data(foo), YES, n, c))) { 476 | drop(foo); 477 | val(At2) = x; 478 | return car(data(c[0])); 479 | } 480 | for (i = 0; i < n; ++i) 481 | data(c[i]) = cdr(data(c[i])); 482 | } 483 | } 484 | drop(foo); 485 | return Nil; 486 | } 487 | 488 | // (pick 'fun 'lst ..) -> any 489 | any doPick(any ex) { 490 | any x = cdr(ex); 491 | cell foo; 492 | 493 | Push(foo, EVAL(car(x))); 494 | if (isCell(x = cdr(x))) { 495 | int i, n = 0; 496 | cell c[length(x)]; 497 | 498 | do 499 | Push(c[n], EVAL(car(x))), ++n; 500 | while (isCell(x = cdr(x))); 501 | while (isCell(data(c[0]))) { 502 | if (!isNil(x = apply(ex, data(foo), YES, n, c))) { 503 | drop(foo); 504 | return x; 505 | } 506 | for (i = 0; i < n; ++i) 507 | data(c[i]) = cdr(data(c[i])); 508 | } 509 | } 510 | drop(foo); 511 | return Nil; 512 | } 513 | 514 | // (fully 'fun 'lst ..) -> flg 515 | any doFully(any ex) { 516 | any x = cdr(ex); 517 | cell foo; 518 | 519 | Push(foo, EVAL(car(x))); 520 | if (isCell(x = cdr(x))) { 521 | int i, n = 0; 522 | cell c[length(x)]; 523 | 524 | do 525 | Push(c[n], EVAL(car(x))), ++n; 526 | while (isCell(x = cdr(x))); 527 | while (isCell(data(c[0]))) { 528 | if (isNil(apply(ex, data(foo), YES, n, c))) { 529 | drop(foo); 530 | return Nil; 531 | } 532 | for (i = 0; i < n; ++i) 533 | data(c[i]) = cdr(data(c[i])); 534 | } 535 | } 536 | drop(foo); 537 | return T; 538 | } 539 | 540 | // (cnt 'fun 'lst ..) -> num 541 | any doCnt(any ex) { 542 | any x = cdr(ex); 543 | int res; 544 | cell foo; 545 | 546 | res = 0; 547 | Push(foo, EVAL(car(x))); 548 | if (isCell(x = cdr(x))) { 549 | int i, n = 0; 550 | cell c[length(x)]; 551 | 552 | do 553 | Push(c[n], EVAL(car(x))), ++n; 554 | while (isCell(x = cdr(x))); 555 | while (isCell(data(c[0]))) { 556 | if (!isNil(apply(ex, data(foo), YES, n, c))) 557 | ++res; 558 | for (i = 0; i < n; ++i) 559 | data(c[i]) = cdr(data(c[i])); 560 | } 561 | } 562 | drop(foo); 563 | return box(res); 564 | } 565 | 566 | // (sum 'fun 'lst ..) -> num 567 | any doSum(any ex) { 568 | any x = cdr(ex); 569 | int res; 570 | cell foo; 571 | 572 | res = 0; 573 | Push(foo, EVAL(car(x))); 574 | if (isCell(x = cdr(x))) { 575 | int i, n = 0; 576 | cell c[length(x)]; 577 | 578 | do 579 | Push(c[n], EVAL(car(x))), ++n; 580 | while (isCell(x = cdr(x))); 581 | while (isCell(data(c[0]))) { 582 | if (isNum(x = apply(ex, data(foo), YES, n, c))) 583 | res += unBox(x); 584 | for (i = 0; i < n; ++i) 585 | data(c[i]) = cdr(data(c[i])); 586 | } 587 | } 588 | drop(foo); 589 | return box(res); 590 | } 591 | 592 | // (maxi 'fun 'lst ..) -> any 593 | any doMaxi(any ex) { 594 | any x = cdr(ex); 595 | cell res, val, foo; 596 | 597 | Push(res, Nil); 598 | Push(val, Nil); 599 | Push(foo, EVAL(car(x))); 600 | if (isCell(x = cdr(x))) { 601 | int i, n = 0; 602 | cell c[length(x)]; 603 | 604 | do 605 | Push(c[n], EVAL(car(x))), ++n; 606 | while (isCell(x = cdr(x))); 607 | while (isCell(data(c[0]))) { 608 | if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) > 0) 609 | data(res) = car(data(c[0])), data(val) = x; 610 | for (i = 0; i < n; ++i) 611 | data(c[i]) = cdr(data(c[i])); 612 | } 613 | } 614 | val(At2) = data(val); 615 | return Pop(res); 616 | } 617 | 618 | // (mini 'fun 'lst ..) -> any 619 | any doMini(any ex) { 620 | any x = cdr(ex); 621 | cell res, val, foo; 622 | 623 | Push(res, Nil); 624 | Push(val, T); 625 | Push(foo, EVAL(car(x))); 626 | if (isCell(x = cdr(x))) { 627 | int i, n = 0; 628 | cell c[length(x)]; 629 | 630 | do 631 | Push(c[n], EVAL(car(x))), ++n; 632 | while (isCell(x = cdr(x))); 633 | while (isCell(data(c[0]))) { 634 | if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) < 0) 635 | data(res) = car(data(c[0])), data(val) = x; 636 | for (i = 0; i < n; ++i) 637 | data(c[i]) = cdr(data(c[i])); 638 | } 639 | } 640 | val(At2) = data(val); 641 | return Pop(res); 642 | } 643 | 644 | static void fish(any ex, any foo, any x, cell *r) { 645 | if (!isNil(apply(ex, foo, NO, 1, (cell*)&x))) 646 | data(*r) = cons(x, data(*r)); 647 | else if (isCell(x)) { 648 | if (!isNil(cdr(x))) 649 | fish(ex, foo, cdr(x), r); 650 | fish(ex, foo, car(x), r); 651 | } 652 | } 653 | 654 | // (fish 'fun 'any) -> lst 655 | any doFish(any ex) { 656 | any x = cdr(ex); 657 | cell res, foo, c1; 658 | 659 | Push(res, Nil); 660 | Push(foo, EVAL(car(x))); 661 | x = cdr(x), Push(c1, EVAL(car(x))); 662 | fish(ex, data(foo), data(c1), &res); 663 | return Pop(res); 664 | } 665 | 666 | // (by 'fun1 'fun2 'lst ..) -> lst 667 | any doBy(any ex) { 668 | any x = cdr(ex); 669 | cell res, foo1, foo2; 670 | 671 | Push(res, Nil); 672 | Push(foo1, EVAL(car(x))), x = cdr(x), Push(foo2, EVAL(car(x))); 673 | if (isCell(x = cdr(x))) { 674 | int i, n = 0; 675 | cell c[length(x)]; 676 | 677 | do 678 | Push(c[n], EVAL(car(x))), ++n; 679 | while (isCell(x = cdr(x))); 680 | if (!isCell(data(c[0]))) 681 | return Pop(res); 682 | data(res) = x = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 683 | while (isCell(data(c[0]) = cdr(data(c[0])))) { 684 | for (i = 1; i < n; ++i) 685 | data(c[i]) = cdr(data(c[i])); 686 | cdr(x) = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 687 | x = cdr(x); 688 | } 689 | data(res) = apply(ex, data(foo2), NO, 1, &res); 690 | for (x = data(res); isCell(x); x = cdr(x)) 691 | car(x) = cdar(x); 692 | } 693 | return Pop(res); 694 | } 695 | -------------------------------------------------------------------------------- /src/flow.c: -------------------------------------------------------------------------------- 1 | /* 29sep15abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | static void redefMsg(any x, any y) { 8 | FILE *oSave = OutFile; 9 | 10 | OutFile = stderr; 11 | outString("# "); 12 | print(x); 13 | if (y) 14 | space(), print(y); 15 | outString(" redefined\n"); 16 | OutFile = oSave; 17 | } 18 | 19 | static void redefine(any ex, any s, any x) { 20 | NeedSymb(ex,s); 21 | CheckVar(ex,s); 22 | if (!isNil(val(s)) && s != val(s) && !equal(x,val(s))) 23 | redefMsg(s,NULL); 24 | val(s) = x; 25 | } 26 | 27 | // (quote . any) -> any 28 | any doQuote(any x) {return cdr(x);} 29 | 30 | // (as 'any1 . any2) -> any2 | NIL 31 | any doAs(any x) { 32 | x = cdr(x); 33 | if (isNil(EVAL(car(x)))) 34 | return Nil; 35 | return cdr(x); 36 | } 37 | 38 | // (lit 'any) -> any 39 | any doLit(any x) { 40 | x = cadr(x); 41 | if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x))) 42 | return x; 43 | return cons(Quote, x); 44 | } 45 | 46 | // (eval 'any ['cnt ['lst]]) -> any 47 | any doEval(any x) { 48 | any y; 49 | cell c1; 50 | bindFrame *p; 51 | 52 | x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x); 53 | if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) 54 | data(c1) = EVAL(data(c1)); 55 | else { 56 | int cnt, n, i, j; 57 | struct { // bindFrame 58 | struct bindFrame *link; 59 | int i, cnt; 60 | struct {any sym; any val;} bnd[length(x)]; 61 | } f; 62 | 63 | x = cdr(x), x = EVAL(car(x)); 64 | j = cnt = (int)unBox(y); 65 | n = f.i = f.cnt = 0; 66 | do { 67 | ++n; 68 | if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { 69 | for (i = 0; i < p->cnt; ++i) { 70 | y = val(p->bnd[i].sym); 71 | val(p->bnd[i].sym) = p->bnd[i].val; 72 | p->bnd[i].val = y; 73 | } 74 | if (p->cnt && p->bnd[0].sym == At && !--j) 75 | break; 76 | } 77 | } while (p = p->link); 78 | while (isCell(x)) { 79 | for (p = Env.bind, j = n; ; p = p->link) { 80 | if (p->i < 0) 81 | for (i = 0; i < p->cnt; ++i) { 82 | if (p->bnd[i].sym == car(x)) { 83 | f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 84 | val(car(x)) = p->bnd[i].val; 85 | ++f.cnt; 86 | goto next; 87 | } 88 | } 89 | if (!--j) 90 | break; 91 | } 92 | next: x = cdr(x); 93 | } 94 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 95 | data(c1) = EVAL(data(c1)); 96 | while (--f.cnt >= 0) 97 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 98 | Env.bind = f.link; 99 | do { 100 | for (p = Env.bind, i = n; --i; p = p->link); 101 | if (p->i < 0 && (p->i += cnt) == 0) 102 | for (i = p->cnt; --i >= 0;) { 103 | y = val(p->bnd[i].sym); 104 | val(p->bnd[i].sym) = p->bnd[i].val; 105 | p->bnd[i].val = y; 106 | } 107 | } while (--n); 108 | } 109 | return Pop(c1); 110 | } 111 | 112 | // (run 'any ['cnt ['lst]]) -> any 113 | any doRun(any x) { 114 | any y; 115 | cell c1; 116 | bindFrame *p; 117 | 118 | x = cdr(x), data(c1) = EVAL(car(x)), x = cdr(x); 119 | if (!isNum(data(c1))) { 120 | Save(c1); 121 | if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) 122 | data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1)); 123 | else { 124 | int cnt, n, i, j; 125 | struct { // bindFrame 126 | struct bindFrame *link; 127 | int i, cnt; 128 | struct {any sym; any val;} bnd[length(x)]; 129 | } f; 130 | 131 | x = cdr(x), x = EVAL(car(x)); 132 | j = cnt = (int)unBox(y); 133 | n = f.i = f.cnt = 0; 134 | do { 135 | ++n; 136 | if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { 137 | for (i = 0; i < p->cnt; ++i) { 138 | y = val(p->bnd[i].sym); 139 | val(p->bnd[i].sym) = p->bnd[i].val; 140 | p->bnd[i].val = y; 141 | } 142 | if (p->cnt && p->bnd[0].sym == At && !--j) 143 | break; 144 | } 145 | } while (p = p->link); 146 | while (isCell(x)) { 147 | for (p = Env.bind, j = n; ; p = p->link) { 148 | if (p->i < 0) 149 | for (i = 0; i < p->cnt; ++i) { 150 | if (p->bnd[i].sym == car(x)) { 151 | f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 152 | val(car(x)) = p->bnd[i].val; 153 | ++f.cnt; 154 | goto next; 155 | } 156 | } 157 | if (!--j) 158 | break; 159 | } 160 | next: x = cdr(x); 161 | } 162 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 163 | data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1)); 164 | while (--f.cnt >= 0) 165 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 166 | Env.bind = f.link; 167 | do { 168 | for (p = Env.bind, i = n; --i; p = p->link); 169 | if (p->i < 0 && (p->i += cnt) == 0) 170 | for (i = p->cnt; --i >= 0;) { 171 | y = val(p->bnd[i].sym); 172 | val(p->bnd[i].sym) = p->bnd[i].val; 173 | p->bnd[i].val = y; 174 | } 175 | } while (--n); 176 | } 177 | drop(c1); 178 | } 179 | return data(c1); 180 | } 181 | 182 | // (def 'sym 'any) -> sym 183 | // (def 'sym 'sym 'any) -> sym 184 | any doDef(any ex) { 185 | any x, y; 186 | cell c1, c2, c3; 187 | 188 | x = cdr(ex), Push(c1, EVAL(car(x))); 189 | NeedSymb(ex,data(c1)); 190 | x = cdr(x), Push(c2, EVAL(car(x))); 191 | if (!isCell(cdr(x))) { 192 | CheckVar(ex,data(c1)); 193 | if (!isNil(y = val(data(c1))) && y != data(c1) && !equal(data(c2), y)) 194 | redefMsg(data(c1),NULL); 195 | val(data(c1)) = data(c2); 196 | } 197 | else { 198 | x = cdr(x), Push(c3, EVAL(car(x))); 199 | if (!isNil(y = get(data(c1), data(c2))) && !equal(data(c3), y)) 200 | redefMsg(data(c1), data(c2)); 201 | put(data(c1), data(c2), data(c3)); 202 | } 203 | return Pop(c1); 204 | } 205 | 206 | // (de sym . any) -> sym 207 | any doDe(any ex) { 208 | redefine(ex, cadr(ex), cddr(ex)); 209 | return cadr(ex); 210 | } 211 | 212 | // (dm sym . fun) -> sym 213 | // (dm (sym . cls) . fun) -> sym 214 | // (dm (sym sym [. cls]) . fun) -> sym 215 | any doDm(any ex) { 216 | any x, y, msg, cls; 217 | 218 | x = cdr(ex); 219 | if (!isCell(car(x))) 220 | msg = car(x), cls = val(Class); 221 | else { 222 | msg = caar(x); 223 | cls = !isCell(cdar(x))? cdar(x) : 224 | get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x)); 225 | } 226 | if (msg != T) 227 | redefine(ex, msg, val(Meth)); 228 | if (isSymb(cdr(x))) { 229 | y = val(cdr(x)); 230 | for (;;) { 231 | if (!isCell(y) || !isCell(car(y))) 232 | err(ex, msg, "Bad message"); 233 | if (caar(y) == msg) { 234 | x = car(y); 235 | break; 236 | } 237 | y = cdr(y); 238 | } 239 | } 240 | for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y)) 241 | if (caar(y) == msg) { 242 | if (!equal(cdr(x), cdar(y))) 243 | redefMsg(msg,cls); 244 | cdar(y) = cdr(x); 245 | return msg; 246 | } 247 | if (!isCell(car(x))) 248 | val(cls) = cons(x, val(cls)); 249 | else 250 | val(cls) = cons(cons(msg, cdr(x)), val(cls)); 251 | return msg; 252 | } 253 | 254 | /* Evaluate method invocation */ 255 | static any evMethod(any o, any expr, any x) { 256 | any y = car(expr); 257 | any cls = TheCls, key = TheKey; 258 | struct { // bindFrame 259 | struct bindFrame *link; 260 | int i, cnt; 261 | struct {any sym; any val;} bnd[length(y)+3]; 262 | } f; 263 | 264 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 265 | f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2; 266 | f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 267 | while (isCell(y)) { 268 | f.bnd[f.cnt].sym = car(y); 269 | f.bnd[f.cnt].val = EVAL(car(x)); 270 | ++f.cnt, x = cdr(x), y = cdr(y); 271 | } 272 | if (isNil(y)) { 273 | do { 274 | x = val(f.bnd[--f.i].sym); 275 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 276 | f.bnd[f.i].val = x; 277 | } while (f.i); 278 | f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 279 | y = cls, cls = Env.cls; Env.cls = y; 280 | y = key, key = Env.key; Env.key = y; 281 | x = prog(cdr(expr)); 282 | } 283 | else if (y != At) { 284 | f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; 285 | do { 286 | x = val(f.bnd[--f.i].sym); 287 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 288 | f.bnd[f.i].val = x; 289 | } while (f.i); 290 | f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 291 | y = cls, cls = Env.cls; Env.cls = y; 292 | y = key, key = Env.key; Env.key = y; 293 | x = prog(cdr(expr)); 294 | } 295 | else { 296 | int n, cnt; 297 | cell *arg; 298 | cell c[n = cnt = length(x)]; 299 | 300 | while (--n >= 0) 301 | Push(c[n], EVAL(car(x))), x = cdr(x); 302 | do { 303 | x = val(f.bnd[--f.i].sym); 304 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 305 | f.bnd[f.i].val = x; 306 | } while (f.i); 307 | n = Env.next, Env.next = cnt; 308 | arg = Env.arg, Env.arg = c; 309 | f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 310 | y = cls, cls = Env.cls; Env.cls = y; 311 | y = key, key = Env.key; Env.key = y; 312 | x = prog(cdr(expr)); 313 | if (cnt) 314 | drop(c[cnt-1]); 315 | Env.arg = arg, Env.next = n; 316 | } 317 | while (--f.cnt >= 0) 318 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 319 | Env.bind = f.link; 320 | Env.cls = cls, Env.key = key; 321 | return x; 322 | } 323 | 324 | any method(any x) { 325 | any y, z; 326 | 327 | if (isCell(y = val(x))) { 328 | while (isCell(z = car(y))) { 329 | if (car(z) == TheKey) 330 | return cdr(z); 331 | if (!isCell(y = cdr(y))) 332 | return NULL; 333 | } 334 | do 335 | if (x = method(car(TheCls = y))) 336 | return x; 337 | while (isCell(y = cdr(y))); 338 | } 339 | return NULL; 340 | } 341 | 342 | // (box 'any) -> sym 343 | any doBox(any x) { 344 | x = cdr(x); 345 | return consSym(EVAL(car(x)),0); 346 | } 347 | 348 | // (new ['typ ['any ..]]) -> obj 349 | any doNew(any ex) { 350 | any x, y; 351 | cell c1, c2; 352 | 353 | x = cdr(ex); 354 | Push(c1, consSym(EVAL(car(x)),0)); 355 | TheKey = T, TheCls = NULL; 356 | if (y = method(data(c1))) 357 | evMethod(data(c1), y, cdr(x)); 358 | else { 359 | Save(c2); 360 | while (isCell(x = cdr(x))) { 361 | data(c2) = EVAL(car(x)), x = cdr(x); 362 | put(data(c1), data(c2), EVAL(car(x))); 363 | } 364 | } 365 | return Pop(c1); 366 | } 367 | 368 | // (type 'any) -> lst 369 | any doType(any ex) { 370 | any x, y, z; 371 | 372 | x = cdr(ex), x = EVAL(car(x)); 373 | if (isSymb(x)) { 374 | z = x = val(x); 375 | while (isCell(x)) { 376 | if (!isCell(car(x))) { 377 | y = x; 378 | while (isSymb(car(x))) { 379 | if (!isCell(x = cdr(x))) 380 | return isNil(x)? y : Nil; 381 | if (z == x) 382 | return Nil; 383 | } 384 | return Nil; 385 | } 386 | if (z == (x = cdr(x))) 387 | return Nil; 388 | } 389 | } 390 | return Nil; 391 | } 392 | 393 | static bool isa(any ex, any cls, any x) { 394 | any z; 395 | 396 | z = x = val(x); 397 | while (isCell(x)) { 398 | if (!isCell(car(x))) { 399 | while (isSymb(car(x))) { 400 | if (cls == car(x) || isa(ex, cls, car(x))) 401 | return YES; 402 | if (!isCell(x = cdr(x)) || z == x) 403 | return NO; 404 | } 405 | return NO; 406 | } 407 | if (z == (x = cdr(x))) 408 | return NO; 409 | } 410 | return NO; 411 | } 412 | 413 | // (isa 'cls|typ 'any) -> obj | NIL 414 | any doIsa(any ex) { 415 | any x; 416 | cell c1; 417 | 418 | x = cdr(ex), Push(c1, EVAL(car(x))); 419 | x = cdr(x), x = EVAL(car(x)); 420 | drop(c1); 421 | if (isSymb(x)) { 422 | if (isSymb(data(c1))) 423 | return isa(ex, data(c1), x)? x : Nil; 424 | while (isCell(data(c1))) { 425 | if (!isa(ex, car(data(c1)), x)) 426 | return Nil; 427 | data(c1) = cdr(data(c1)); 428 | } 429 | return x; 430 | } 431 | return Nil; 432 | } 433 | 434 | // (method 'msg 'obj) -> fun 435 | any doMethod(any ex) { 436 | any x, y; 437 | 438 | x = cdr(ex), y = EVAL(car(x)); 439 | x = cdr(x), x = EVAL(car(x)); 440 | TheKey = y; 441 | return method(x)? : Nil; 442 | } 443 | 444 | // (meth 'obj ..) -> any 445 | any doMeth(any ex) { 446 | any x, y; 447 | cell c1; 448 | 449 | x = cdr(ex), Push(c1, EVAL(car(x))); 450 | NeedSymb(ex,data(c1)); 451 | for (TheKey = car(ex); ; TheKey = val(TheKey)) { 452 | if (!isSymb(TheKey)) 453 | err(ex, car(ex), "Bad message"); 454 | if (isNum(val(TheKey))) { 455 | TheCls = NULL; 456 | if (y = method(data(c1))) { 457 | x = evMethod(data(c1), y, cdr(x)); 458 | drop(c1); 459 | return x; 460 | } 461 | err(ex, TheKey, "Bad message"); 462 | } 463 | } 464 | } 465 | 466 | // (send 'msg 'obj ['any ..]) -> any 467 | any doSend(any ex) { 468 | any x, y; 469 | cell c1, c2; 470 | 471 | x = cdr(ex), Push(c1, EVAL(car(x))); 472 | NeedSymb(ex,data(c1)); 473 | x = cdr(x), Push(c2, EVAL(car(x))); 474 | NeedSymb(ex,data(c2)); 475 | TheKey = data(c1), TheCls = NULL; 476 | if (y = method(data(c2))) { 477 | x = evMethod(data(c2), y, cdr(x)); 478 | drop(c1); 479 | return x; 480 | } 481 | err(ex, TheKey, "Bad message"); 482 | } 483 | 484 | // (try 'msg 'obj ['any ..]) -> any 485 | any doTry(any ex) { 486 | any x, y; 487 | cell c1, c2; 488 | 489 | x = cdr(ex), Push(c1, EVAL(car(x))); 490 | NeedSymb(ex,data(c1)); 491 | x = cdr(x), Push(c2, EVAL(car(x))); 492 | if (isSymb(data(c2))) { 493 | TheKey = data(c1), TheCls = NULL; 494 | if (y = method(data(c2))) { 495 | x = evMethod(data(c2), y, cdr(x)); 496 | drop(c1); 497 | return x; 498 | } 499 | } 500 | drop(c1); 501 | return Nil; 502 | } 503 | 504 | // (super ['any ..]) -> any 505 | any doSuper(any ex) { 506 | any x, y, cls, key; 507 | 508 | TheKey = Env.key; 509 | x = val(Env.cls? car(Env.cls) : val(This)); 510 | while (isCell(car(x))) 511 | x = cdr(x); 512 | while (isCell(x)) { 513 | if (y = method(car(TheCls = x))) { 514 | cls = Env.cls, Env.cls = TheCls; 515 | key = Env.key, Env.key = TheKey; 516 | x = evExpr(y, cdr(ex)); 517 | Env.key = key, Env.cls = cls; 518 | return x; 519 | } 520 | x = cdr(x); 521 | } 522 | err(ex, TheKey, "Bad super"); 523 | } 524 | 525 | static any extra(any x) { 526 | any y; 527 | 528 | for (x = val(x); isCell(car(x)); x = cdr(x)); 529 | while (isCell(x)) { 530 | if (x == Env.cls || !(y = extra(car(x)))) { 531 | while (isCell(x = cdr(x))) 532 | if (y = method(car(TheCls = x))) 533 | return y; 534 | return NULL; 535 | } 536 | if (y && y != Zero) 537 | return y; 538 | x = cdr(x); 539 | } 540 | return Zero; 541 | } 542 | 543 | // (extra ['any ..]) -> any 544 | any doExtra(any ex) { 545 | any x, y, cls, key; 546 | 547 | TheKey = Env.key; 548 | if ((y = extra(val(This))) && y != Zero) { 549 | cls = Env.cls, Env.cls = TheCls; 550 | key = Env.key, Env.key = TheKey; 551 | x = evExpr(y, cdr(ex)); 552 | Env.key = key, Env.cls = cls; 553 | return x; 554 | } 555 | err(ex, TheKey, "Bad extra"); 556 | } 557 | 558 | // (with 'sym . prg) -> any 559 | any doWith(any ex) { 560 | any x; 561 | bindFrame f; 562 | 563 | x = cdr(ex); 564 | if (isNil(x = EVAL(car(x)))) 565 | return Nil; 566 | NeedSymb(ex,x); 567 | Bind(This,f), val(This) = x; 568 | x = prog(cddr(ex)); 569 | Unbind(f); 570 | return x; 571 | } 572 | 573 | // (bind 'sym|lst . prg) -> any 574 | any doBind(any ex) { 575 | any x, y; 576 | 577 | x = cdr(ex); 578 | if (isNum(y = EVAL(car(x)))) 579 | argError(ex, y); 580 | if (isNil(y)) 581 | return prog(cdr(x)); 582 | if (isSym(y)) { 583 | bindFrame f; 584 | 585 | Bind(y,f); 586 | x = prog(cdr(x)); 587 | Unbind(f); 588 | return x; 589 | } 590 | { 591 | struct { // bindFrame 592 | struct bindFrame *link; 593 | int i, cnt; 594 | struct {any sym; any val;} bnd[length(y)]; 595 | } f; 596 | 597 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 598 | f.i = f.cnt = 0; 599 | do { 600 | if (isNum(car(y))) 601 | argError(ex, car(y)); 602 | if (isSym(car(y))) { 603 | f.bnd[f.cnt].sym = car(y); 604 | f.bnd[f.cnt].val = val(car(y)); 605 | } 606 | else { 607 | f.bnd[f.cnt].sym = caar(y); 608 | f.bnd[f.cnt].val = val(caar(y)); 609 | val(caar(y)) = cdar(y); 610 | } 611 | ++f.cnt; 612 | } while (isCell(y = cdr(y))); 613 | x = prog(cdr(x)); 614 | while (--f.cnt >= 0) 615 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 616 | Env.bind = f.link; 617 | return x; 618 | } 619 | } 620 | 621 | // (job 'lst . prg) -> any 622 | any doJob(any ex) { 623 | any x = cdr(ex); 624 | any y = EVAL(car(x)); 625 | cell c1; 626 | struct { // bindFrame 627 | struct bindFrame *link; 628 | int i, cnt; 629 | struct {any sym; any val;} bnd[length(y)]; 630 | } f; 631 | 632 | Push(c1,y); 633 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 634 | f.i = f.cnt = 0; 635 | while (isCell(y)) { 636 | f.bnd[f.cnt].sym = caar(y); 637 | f.bnd[f.cnt].val = val(caar(y)); 638 | val(caar(y)) = cdar(y); 639 | ++f.cnt, y = cdr(y); 640 | } 641 | x = prog(cdr(x)); 642 | for (f.cnt = 0, y = Pop(c1); isCell(y); ++f.cnt, y = cdr(y)) { 643 | cdar(y) = val(caar(y)); 644 | val(caar(y)) = f.bnd[f.cnt].val; 645 | } 646 | Env.bind = f.link; 647 | return x; 648 | } 649 | 650 | // (let sym 'any . prg) -> any 651 | // (let (sym 'any ..) . prg) -> any 652 | any doLet(any x) { 653 | any y; 654 | 655 | x = cdr(x); 656 | if (!isCell(y = car(x))) { 657 | bindFrame f; 658 | 659 | x = cdr(x), Bind(y,f), val(y) = EVAL(car(x)); 660 | x = prog(cdr(x)); 661 | Unbind(f); 662 | } 663 | else { 664 | struct { // bindFrame 665 | struct bindFrame *link; 666 | int i, cnt; 667 | struct {any sym; any val;} bnd[(length(y)+1)/2]; 668 | } f; 669 | 670 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 671 | f.i = f.cnt = 0; 672 | do { 673 | f.bnd[f.cnt].sym = car(y); 674 | f.bnd[f.cnt].val = val(car(y)); 675 | ++f.cnt; 676 | val(car(y)) = EVAL(cadr(y)); 677 | } while (isCell(y = cddr(y))); 678 | x = prog(cdr(x)); 679 | while (--f.cnt >= 0) 680 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 681 | Env.bind = f.link; 682 | } 683 | return x; 684 | } 685 | 686 | // (let? sym 'any . prg) -> any 687 | any doLetQ(any x) { 688 | any y, z; 689 | bindFrame f; 690 | 691 | x = cdr(x), y = car(x), x = cdr(x); 692 | if (isNil(z = EVAL(car(x)))) 693 | return Nil; 694 | Bind(y,f), val(y) = z; 695 | x = prog(cdr(x)); 696 | Unbind(f); 697 | return x; 698 | } 699 | 700 | // (use sym . prg) -> any 701 | // (use (sym ..) . prg) -> any 702 | any doUse(any x) { 703 | any y; 704 | 705 | x = cdr(x); 706 | if (!isCell(y = car(x))) { 707 | bindFrame f; 708 | 709 | Bind(y,f); 710 | x = prog(cdr(x)); 711 | Unbind(f); 712 | } 713 | else { 714 | struct { // bindFrame 715 | struct bindFrame *link; 716 | int i, cnt; 717 | struct {any sym; any val;} bnd[length(y)]; 718 | } f; 719 | 720 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 721 | f.i = f.cnt = 0; 722 | do { 723 | f.bnd[f.cnt].sym = car(y); 724 | f.bnd[f.cnt].val = val(car(y)); 725 | ++f.cnt; 726 | } while (isCell(y = cdr(y))); 727 | x = prog(cdr(x)); 728 | while (--f.cnt >= 0) 729 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 730 | Env.bind = f.link; 731 | } 732 | return x; 733 | } 734 | 735 | // (and 'any ..) -> any 736 | any doAnd(any x) { 737 | any a; 738 | 739 | x = cdr(x); 740 | do { 741 | if (isNil(a = EVAL(car(x)))) 742 | return Nil; 743 | val(At) = a; 744 | } while (isCell(x = cdr(x))); 745 | return a; 746 | } 747 | 748 | // (or 'any ..) -> any 749 | any doOr(any x) { 750 | any a; 751 | 752 | x = cdr(x); 753 | do 754 | if (!isNil(a = EVAL(car(x)))) 755 | return val(At) = a; 756 | while (isCell(x = cdr(x))); 757 | return Nil; 758 | } 759 | 760 | // (nand 'any ..) -> flg 761 | any doNand(any x) { 762 | any a; 763 | 764 | x = cdr(x); 765 | do { 766 | if (isNil(a = EVAL(car(x)))) 767 | return T; 768 | val(At) = a; 769 | } while (isCell(x = cdr(x))); 770 | return Nil; 771 | } 772 | 773 | // (nor 'any ..) -> flg 774 | any doNor(any x) { 775 | any a; 776 | 777 | x = cdr(x); 778 | do 779 | if (!isNil(a = EVAL(car(x)))) { 780 | val(At) = a; 781 | return Nil; 782 | } 783 | while (isCell(x = cdr(x))); 784 | return T; 785 | } 786 | 787 | // (xor 'any 'any) -> flg 788 | any doXor(any x) { 789 | bool f; 790 | 791 | x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x); 792 | return f ^ isNil(EVAL(car(x)))? T : Nil; 793 | } 794 | 795 | // (bool 'any) -> flg 796 | any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;} 797 | 798 | // (not 'any) -> flg 799 | any doNot(any x) { 800 | any a; 801 | 802 | if (isNil(a = EVAL(cadr(x)))) 803 | return T; 804 | val(At) = a; 805 | return Nil; 806 | } 807 | 808 | // (nil . prg) -> NIL 809 | any doNil(any x) { 810 | while (isCell(x = cdr(x))) 811 | if (isCell(car(x))) 812 | evList(car(x)); 813 | return Nil; 814 | } 815 | 816 | // (t . prg) -> T 817 | any doT(any x) { 818 | while (isCell(x = cdr(x))) 819 | if (isCell(car(x))) 820 | evList(car(x)); 821 | return T; 822 | } 823 | 824 | // (prog . prg) -> any 825 | any doProg(any x) {return prog(cdr(x));} 826 | 827 | // (prog1 'any1 . prg) -> any1 828 | any doProg1(any x) { 829 | cell c1; 830 | 831 | x = cdr(x), Push(c1, val(At) = EVAL(car(x))); 832 | while (isCell(x = cdr(x))) 833 | if (isCell(car(x))) 834 | evList(car(x)); 835 | return Pop(c1); 836 | } 837 | 838 | // (prog2 'any1 'any2 . prg) -> any2 839 | any doProg2(any x) { 840 | cell c1; 841 | 842 | x = cdr(x), EVAL(car(x)); 843 | x = cdr(x), Push(c1, val(At) = EVAL(car(x))); 844 | while (isCell(x = cdr(x))) 845 | if (isCell(car(x))) 846 | evList(car(x)); 847 | return Pop(c1); 848 | } 849 | 850 | // (if 'any1 any2 . prg) -> any 851 | any doIf(any x) { 852 | any a; 853 | 854 | x = cdr(x); 855 | if (isNil(a = EVAL(car(x)))) 856 | return prog(cddr(x)); 857 | val(At) = a; 858 | x = cdr(x); 859 | return EVAL(car(x)); 860 | } 861 | 862 | // (if2 'any1 'any2 any3 any4 any5 . prg) -> any 863 | any doIf2(any x) { 864 | any a; 865 | 866 | x = cdr(x); 867 | if (isNil(a = EVAL(car(x)))) { 868 | x = cdr(x); 869 | if (isNil(a = EVAL(car(x)))) 870 | return prog(cddddr(x)); 871 | val(At) = a; 872 | x = cdddr(x); 873 | return EVAL(car(x)); 874 | } 875 | val(At) = a; 876 | x = cdr(x); 877 | if (isNil(a = EVAL(car(x)))) { 878 | x = cddr(x); 879 | return EVAL(car(x)); 880 | } 881 | val(At) = a; 882 | x = cdr(x); 883 | return EVAL(car(x)); 884 | } 885 | 886 | // (ifn 'any1 any2 . prg) -> any 887 | any doIfn(any x) { 888 | any a; 889 | 890 | x = cdr(x); 891 | if (!isNil(a = EVAL(car(x)))) { 892 | val(At) = a; 893 | return prog(cddr(x)); 894 | } 895 | x = cdr(x); 896 | return EVAL(car(x)); 897 | } 898 | 899 | // (when 'any . prg) -> any 900 | any doWhen(any x) { 901 | any a; 902 | 903 | x = cdr(x); 904 | if (isNil(a = EVAL(car(x)))) 905 | return Nil; 906 | val(At) = a; 907 | return prog(cdr(x)); 908 | } 909 | 910 | // (unless 'any . prg) -> any 911 | any doUnless(any x) { 912 | any a; 913 | 914 | x = cdr(x); 915 | if (!isNil(a = EVAL(car(x)))) { 916 | val(At) = a; 917 | return Nil; 918 | } 919 | return prog(cdr(x)); 920 | } 921 | 922 | // (cond ('any1 . prg1) ('any2 . prg2) ..) -> any 923 | any doCond(any x) { 924 | any a; 925 | 926 | while (isCell(x = cdr(x))) { 927 | if (!isNil(a = EVAL(caar(x)))) { 928 | val(At) = a; 929 | return prog(cdar(x)); 930 | } 931 | } 932 | return Nil; 933 | } 934 | 935 | // (nond ('any1 . prg1) ('any2 . prg2) ..) -> any 936 | any doNond(any x) { 937 | any a; 938 | 939 | while (isCell(x = cdr(x))) { 940 | if (isNil(a = EVAL(caar(x)))) 941 | return prog(cdar(x)); 942 | val(At) = a; 943 | } 944 | return Nil; 945 | } 946 | 947 | // (case 'any (any1 . prg1) (any2 . prg2) ..) -> any 948 | any doCase(any x) { 949 | any y, z; 950 | 951 | x = cdr(x), val(At) = EVAL(car(x)); 952 | while (isCell(x = cdr(x))) { 953 | y = car(x), z = car(y); 954 | if (z == T || equal(val(At), z)) 955 | return prog(cdr(y)); 956 | if (isCell(z)) { 957 | do 958 | if (equal(val(At), car(z))) 959 | return prog(cdr(y)); 960 | while (isCell(z = cdr(z))); 961 | } 962 | } 963 | return Nil; 964 | } 965 | 966 | // (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any 967 | any doCasq(any x) { 968 | any y, z; 969 | 970 | x = cdr(x), val(At) = EVAL(car(x)); 971 | while (isCell(x = cdr(x))) { 972 | y = car(x), z = car(y); 973 | if (z == T || z == val(At)) 974 | return prog(cdr(y)); 975 | if (isCell(z)) { 976 | do 977 | if (car(z) == val(At)) 978 | return prog(cdr(y)); 979 | while (isCell(z = cdr(z))); 980 | } 981 | } 982 | return Nil; 983 | } 984 | 985 | // (state 'var (sym|lst exe [. prg]) ..) -> any 986 | any doState(any ex) { 987 | any x, y, a; 988 | cell c1; 989 | 990 | x = cdr(ex); 991 | Push(c1, EVAL(car(x))); 992 | NeedVar(ex,data(c1)); 993 | CheckVar(ex,data(c1)); 994 | while (isCell(x = cdr(x))) { 995 | y = car(x); 996 | if (car(y) == T || memq(val(data(c1)), car(y))) { 997 | y = cdr(y); 998 | if (!isNil(a = EVAL(car(y)))) { 999 | val(At) = val(data(c1)) = a; 1000 | drop(c1); 1001 | return prog(cdr(y)); 1002 | } 1003 | } 1004 | } 1005 | drop(c1); 1006 | return Nil; 1007 | } 1008 | 1009 | // (while 'any . prg) -> any 1010 | any doWhile(any x) { 1011 | any cond, a; 1012 | cell c1; 1013 | 1014 | cond = car(x = cdr(x)), x = cdr(x); 1015 | Push(c1, Nil); 1016 | while (!isNil(a = EVAL(cond))) { 1017 | val(At) = a; 1018 | data(c1) = prog(x); 1019 | } 1020 | return Pop(c1); 1021 | } 1022 | 1023 | // (until 'any . prg) -> any 1024 | any doUntil(any x) { 1025 | any cond, a; 1026 | cell c1; 1027 | 1028 | cond = car(x = cdr(x)), x = cdr(x); 1029 | Push(c1, Nil); 1030 | while (isNil(a = EVAL(cond))) 1031 | data(c1) = prog(x); 1032 | val(At) = a; 1033 | return Pop(c1); 1034 | } 1035 | 1036 | // (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1037 | any doLoop(any ex) { 1038 | any x, y, a; 1039 | 1040 | for (;;) { 1041 | x = cdr(ex); 1042 | do { 1043 | if (isCell(y = car(x))) { 1044 | if (isNil(car(y))) { 1045 | y = cdr(y); 1046 | if (isNil(a = EVAL(car(y)))) 1047 | return prog(cdr(y)); 1048 | val(At) = a; 1049 | } 1050 | else if (car(y) == T) { 1051 | y = cdr(y); 1052 | if (!isNil(a = EVAL(car(y)))) { 1053 | val(At) = a; 1054 | return prog(cdr(y)); 1055 | } 1056 | } 1057 | else 1058 | evList(y); 1059 | } 1060 | } while (isCell(x = cdr(x))); 1061 | } 1062 | } 1063 | 1064 | // (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1065 | any doDo(any x) { 1066 | any f, y, z, a; 1067 | 1068 | x = cdr(x); 1069 | if (isNil(f = EVAL(car(x)))) 1070 | return Nil; 1071 | if (isNum(f) && num(f) < 0) 1072 | return Nil; 1073 | x = cdr(x), z = Nil; 1074 | for (;;) { 1075 | if (isNum(f)) { 1076 | if (f == Zero) 1077 | return z; 1078 | f = (any)(num(f) - 4); 1079 | } 1080 | y = x; 1081 | do { 1082 | if (!isNum(z = car(y))) { 1083 | if (isSym(z)) 1084 | z = val(z); 1085 | else if (isNil(car(z))) { 1086 | z = cdr(z); 1087 | if (isNil(a = EVAL(car(z)))) 1088 | return prog(cdr(z)); 1089 | val(At) = a; 1090 | z = Nil; 1091 | } 1092 | else if (car(z) == T) { 1093 | z = cdr(z); 1094 | if (!isNil(a = EVAL(car(z)))) { 1095 | val(At) = a; 1096 | return prog(cdr(z)); 1097 | } 1098 | z = Nil; 1099 | } 1100 | else 1101 | z = evList(z); 1102 | } 1103 | } while (isCell(y = cdr(y))); 1104 | } 1105 | } 1106 | 1107 | // (at '(cnt1 . cnt2|NIL) . prg) -> any 1108 | any doAt(any ex) { 1109 | any x; 1110 | 1111 | x = cdr(ex), x = EVAL(car(x)); 1112 | NeedPair(ex,x); 1113 | if (isNil(cdr(x))) 1114 | return Nil; 1115 | NeedNum(ex,car(x)); 1116 | NeedNum(ex,cdr(x)); 1117 | if (num(car(x) = (any)(num(car(x)) + 4)) < num(cdr(x))) 1118 | return Nil; 1119 | car(x) = Zero; 1120 | return prog(cddr(ex)); 1121 | } 1122 | 1123 | // (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1124 | // (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1125 | // (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1126 | any doFor(any x) { 1127 | any y, body, cond, a; 1128 | cell c1; 1129 | struct { // bindFrame 1130 | struct bindFrame *link; 1131 | int i, cnt; 1132 | struct {any sym; any val;} bnd[2]; 1133 | } f; 1134 | 1135 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 1136 | f.i = 0; 1137 | if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) { 1138 | if (!isCell(y)) { 1139 | f.cnt = 1; 1140 | f.bnd[0].sym = y; 1141 | f.bnd[0].val = val(y); 1142 | } 1143 | else { 1144 | f.cnt = 2; 1145 | f.bnd[0].sym = cdr(y); 1146 | f.bnd[0].val = val(cdr(y)); 1147 | f.bnd[1].sym = car(y); 1148 | f.bnd[1].val = val(car(y)); 1149 | val(f.bnd[1].sym) = Zero; 1150 | } 1151 | y = Nil; 1152 | x = cdr(x), Push(c1, EVAL(car(x))); 1153 | if (isNum(data(c1))) 1154 | val(f.bnd[0].sym) = Zero; 1155 | body = x = cdr(x); 1156 | for (;;) { 1157 | if (isNum(data(c1))) { 1158 | val(f.bnd[0].sym) = (any)(num(val(f.bnd[0].sym)) + 4); 1159 | if (num(val(f.bnd[0].sym)) > num(data(c1))) 1160 | break; 1161 | } 1162 | else { 1163 | if (!isCell(data(c1))) 1164 | break; 1165 | val(f.bnd[0].sym) = car(data(c1)); 1166 | if (!isCell(data(c1) = cdr(data(c1)))) 1167 | data(c1) = Nil; 1168 | } 1169 | if (f.cnt == 2) 1170 | val(f.bnd[1].sym) = (any)(num(val(f.bnd[1].sym)) + 4); 1171 | do { 1172 | if (!isNum(y = car(x))) { 1173 | if (isSym(y)) 1174 | y = val(y); 1175 | else if (isNil(car(y))) { 1176 | y = cdr(y); 1177 | if (isNil(a = EVAL(car(y)))) { 1178 | y = prog(cdr(y)); 1179 | goto for1; 1180 | } 1181 | val(At) = a; 1182 | y = Nil; 1183 | } 1184 | else if (car(y) == T) { 1185 | y = cdr(y); 1186 | if (!isNil(a = EVAL(car(y)))) { 1187 | val(At) = a; 1188 | y = prog(cdr(y)); 1189 | goto for1; 1190 | } 1191 | y = Nil; 1192 | } 1193 | else 1194 | y = evList(y); 1195 | } 1196 | } while (isCell(x = cdr(x))); 1197 | x = body; 1198 | } 1199 | for1: 1200 | drop(c1); 1201 | if (f.cnt == 2) 1202 | val(f.bnd[1].sym) = f.bnd[1].val; 1203 | val(f.bnd[0].sym) = f.bnd[0].val; 1204 | Env.bind = f.link; 1205 | return y; 1206 | } 1207 | if (!isCell(car(y))) { 1208 | f.cnt = 1; 1209 | f.bnd[0].sym = car(y); 1210 | f.bnd[0].val = val(car(y)); 1211 | } 1212 | else { 1213 | f.cnt = 2; 1214 | f.bnd[0].sym = cdar(y); 1215 | f.bnd[0].val = val(cdar(y)); 1216 | f.bnd[1].sym = caar(y); 1217 | f.bnd[1].val = val(caar(y)); 1218 | val(f.bnd[1].sym) = Zero; 1219 | } 1220 | y = cdr(y); 1221 | val(f.bnd[0].sym) = EVAL(car(y)); 1222 | y = cdr(y), cond = car(y), y = cdr(y); 1223 | Push(c1,Nil); 1224 | body = x = cdr(x); 1225 | for (;;) { 1226 | if (f.cnt == 2) 1227 | val(f.bnd[1].sym) = (any)(num(val(f.bnd[1].sym)) + 4); 1228 | if (isNil(a = EVAL(cond))) 1229 | break; 1230 | val(At) = a; 1231 | do { 1232 | if (!isNum(data(c1) = car(x))) { 1233 | if (isSym(data(c1))) 1234 | data(c1) = val(data(c1)); 1235 | else if (isNil(car(data(c1)))) { 1236 | data(c1) = cdr(data(c1)); 1237 | if (isNil(a = EVAL(car(data(c1))))) { 1238 | data(c1) = prog(cdr(data(c1))); 1239 | goto for2; 1240 | } 1241 | val(At) = a; 1242 | data(c1) = Nil; 1243 | } 1244 | else if (car(data(c1)) == T) { 1245 | data(c1) = cdr(data(c1)); 1246 | if (!isNil(a = EVAL(car(data(c1))))) { 1247 | val(At) = a; 1248 | data(c1) = prog(cdr(data(c1))); 1249 | goto for2; 1250 | } 1251 | data(c1) = Nil; 1252 | } 1253 | else 1254 | data(c1) = evList(data(c1)); 1255 | } 1256 | } while (isCell(x = cdr(x))); 1257 | if (isCell(y)) 1258 | val(f.bnd[0].sym) = prog(y); 1259 | x = body; 1260 | } 1261 | for2: 1262 | if (f.cnt == 2) 1263 | val(f.bnd[1].sym) = f.bnd[1].val; 1264 | val(f.bnd[0].sym) = f.bnd[0].val; 1265 | Env.bind = f.link; 1266 | return Pop(c1); 1267 | } 1268 | 1269 | // (catch 'any . prg) -> any 1270 | any doCatch(any x) { 1271 | any y; 1272 | catchFrame f; 1273 | 1274 | x = cdr(x), f.tag = EVAL(car(x)), f.fin = Zero; 1275 | f.link = CatchPtr, CatchPtr = &f; 1276 | f.env = Env; 1277 | y = setjmp(f.rst)? Thrown : prog(cdr(x)); 1278 | CatchPtr = f.link; 1279 | return y; 1280 | } 1281 | 1282 | // (throw 'sym 'any) 1283 | any doThrow(any ex) { 1284 | any x, tag; 1285 | catchFrame *p; 1286 | 1287 | x = cdr(ex), tag = EVAL(car(x)); 1288 | x = cdr(x), Thrown = EVAL(car(x)); 1289 | for (p = CatchPtr; p; p = p->link) 1290 | if (p->tag == T || tag == p->tag) { 1291 | unwind(p); 1292 | longjmp(p->rst, 1); 1293 | } 1294 | err(ex, tag, "Tag not found"); 1295 | } 1296 | 1297 | // (finally exe . prg) -> any 1298 | any doFinally(any x) { 1299 | catchFrame f; 1300 | cell c1; 1301 | 1302 | x = cdr(x), f.tag = NULL, f.fin = car(x); 1303 | f.link = CatchPtr, CatchPtr = &f; 1304 | f.env = Env; 1305 | Push(c1, prog(cdr(x))); 1306 | EVAL(f.fin); 1307 | CatchPtr = f.link; 1308 | return Pop(c1); 1309 | } 1310 | 1311 | static outFrame Out; 1312 | static struct { // bindFrame 1313 | struct bindFrame *link; 1314 | int i, cnt; 1315 | struct {any sym; any val;} bnd[2]; // for 'Up' and 'At' 1316 | } Brk; 1317 | 1318 | void brkLoad(any x) { 1319 | if (!Env.brk) { 1320 | Env.brk = YES; 1321 | Brk.cnt = 2; 1322 | Brk.bnd[0].sym = Up, Brk.bnd[0].val = val(Up), val(Up) = x; 1323 | Brk.bnd[1].sym = At, Brk.bnd[1].val = val(At); 1324 | Brk.link = Env.bind, Env.bind = (bindFrame*)&Brk; 1325 | Out.fp = stdout, pushOutFiles(&Out); 1326 | print(x), newline(); 1327 | load(NULL, '!', Nil); 1328 | popOutFiles(); 1329 | val(At) = Brk.bnd[1].val; 1330 | val(Up) = Brk.bnd[0].val; 1331 | Env.bind = Brk.link; 1332 | Env.brk = NO; 1333 | } 1334 | } 1335 | 1336 | // (! . exe) -> any 1337 | any doBreak(any ex) { 1338 | if (!isNil(val(Dbg))) 1339 | brkLoad(cdr(ex)); 1340 | return EVAL(cdr(ex)); 1341 | } 1342 | 1343 | // (e . prg) -> any 1344 | any doE(any ex) { 1345 | any x; 1346 | cell c1, at; 1347 | 1348 | if (!Env.brk) 1349 | err(ex, NULL, "No Break"); 1350 | Push(c1,val(Dbg)), val(Dbg) = Nil; 1351 | Push(at, val(At)), val(At) = Brk.bnd[1].val; 1352 | if (Env.inFrames && Env.inFrames->link) 1353 | Chr = Env.inFrames->next, Env.get = Env.inFrames->get, InFile = Env.inFrames->link->fp; 1354 | popOutFiles(); 1355 | x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up)); 1356 | pushOutFiles(&Out); 1357 | if (Env.inFrames && Env.inFrames->link) 1358 | Env.inFrames->next = Chr, Chr = 0; 1359 | InFile = stdin, OutFile = stdout; 1360 | val(At) = data(at); 1361 | val(Dbg) = Pop(c1); 1362 | return x; 1363 | } 1364 | 1365 | static void traceIndent(int i, any x, char *s) { 1366 | if (i > 64) 1367 | i = 64; 1368 | while (--i >= 0) 1369 | Env.put(' '); 1370 | if (!isCell(x)) 1371 | print(x); 1372 | else 1373 | print(car(x)), space(), print(cdr(x)), space(), print(val(This)); 1374 | outString(s); 1375 | } 1376 | 1377 | // ($ sym|lst lst . prg) -> any 1378 | any doTrace(any x) { 1379 | any foo, body; 1380 | FILE *oSave; 1381 | void (*putSave)(int); 1382 | cell c1; 1383 | 1384 | x = cdr(x); 1385 | if (isNil(val(Dbg))) 1386 | return prog(cddr(x)); 1387 | oSave = OutFile, OutFile = stderr; 1388 | putSave = Env.put, Env.put = putStdout; 1389 | foo = car(x); 1390 | x = cdr(x), body = cdr(x); 1391 | traceIndent(++Trace, foo, " :"); 1392 | for (x = car(x); isCell(x); x = cdr(x)) 1393 | space(), print(val(car(x))); 1394 | if (!isNil(x)) { 1395 | if (x != At) 1396 | space(), print(val(x)); 1397 | else { 1398 | int i = Env.next; 1399 | 1400 | while (--i >= 0) 1401 | space(), print(data(Env.arg[i])); 1402 | } 1403 | } 1404 | newline(); 1405 | Env.put = putSave; 1406 | OutFile = oSave; 1407 | Push(c1, prog(body)); 1408 | OutFile = stderr; 1409 | Env.put = putStdout; 1410 | traceIndent(Trace--, foo, " = "), print(data(c1)), newline(); 1411 | Env.put = putSave; 1412 | OutFile = oSave; 1413 | return Pop(c1); 1414 | } 1415 | 1416 | // (bye 'num|NIL) 1417 | any doBye(any ex) { 1418 | any x = EVAL(cadr(ex)); 1419 | 1420 | bye(isNil(x)? 0 : xNum(ex,x)); 1421 | } 1422 | -------------------------------------------------------------------------------- /src/gc.c: -------------------------------------------------------------------------------- 1 | /* 26oct14abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | static void mark(any); 8 | 9 | /* Mark data */ 10 | static void markTail(any x) { 11 | while (isCell(x)) { 12 | if (!(num(cdr(x)) & 1)) 13 | return; 14 | *(long*)&cdr(x) &= ~1; 15 | mark(cdr(x)), x = car(x); 16 | } 17 | if (!isTxt(x)) 18 | do { 19 | if (!(num(val(x)) & 1)) 20 | return; 21 | *(long*)&val(x) &= ~1; 22 | } while (!isNum(x = val(x))); 23 | } 24 | 25 | static void mark(any x) { 26 | while (isCell(x)) { 27 | if (!(num(cdr(x)) & 1)) 28 | return; 29 | *(long*)&cdr(x) &= ~1; 30 | mark(car(x)), x = cdr(x); 31 | } 32 | if (!isNum(x) && num(val(x)) & 1) { 33 | *(long*)&val(x) &= ~1; 34 | mark(val(x)); 35 | markTail(tail(x)); 36 | } 37 | } 38 | 39 | /* Garbage collector */ 40 | static void gc(long c) { 41 | any p; 42 | heap *h; 43 | int i; 44 | 45 | h = Heaps; 46 | do { 47 | p = h->cells + CELLS-1; 48 | do 49 | *(long*)&cdr(p) |= 1; 50 | while (--p >= h->cells); 51 | } while (h = h->next); 52 | /* Mark */ 53 | for (i = 0; i < RAMS; i += 2) { 54 | markTail(Ram[i]); 55 | mark(Ram[i+1]); 56 | } 57 | mark(Intern[0]), mark(Intern[1]); 58 | mark(Transient[0]), mark(Transient[1]); 59 | mark(ApplyArgs), mark(ApplyBody); 60 | for (p = Env.stack; p; p = cdr(p)) 61 | mark(car(p)); 62 | for (p = (any)Env.bind; p; p = (any)((bindFrame*)p)->link) 63 | for (i = ((bindFrame*)p)->cnt; --i >= 0;) { 64 | mark(((bindFrame*)p)->bnd[i].sym); 65 | mark(((bindFrame*)p)->bnd[i].val); 66 | } 67 | for (p = (any)CatchPtr; p; p = (any)((catchFrame*)p)->link) { 68 | if (((catchFrame*)p)->tag) 69 | mark(((catchFrame*)p)->tag); 70 | mark(((catchFrame*)p)->fin); 71 | } 72 | /* Sweep */ 73 | Avail = NULL; 74 | h = Heaps; 75 | if (c) { 76 | do { 77 | p = h->cells + CELLS-1; 78 | do 79 | if (num(p->cdr) & 1) 80 | Free(p), --c; 81 | while (--p >= h->cells); 82 | } while (h = h->next); 83 | while (c >= 0) 84 | heapAlloc(), c -= CELLS; 85 | } 86 | else { 87 | heap **hp = &Heaps; 88 | cell *av; 89 | 90 | do { 91 | c = CELLS; 92 | av = Avail; 93 | p = h->cells + CELLS-1; 94 | do 95 | if (num(p->cdr) & 1) 96 | Free(p), --c; 97 | while (--p >= h->cells); 98 | if (c) 99 | hp = &h->next, h = h->next; 100 | else 101 | Avail = av, h = h->next, free(*hp), *hp = h; 102 | } while (h); 103 | } 104 | } 105 | 106 | // (gc ['num]) -> num | NIL 107 | any doGc(any x) { 108 | x = cdr(x), x = EVAL(car(x)); 109 | val(At) = val(At2) = Nil; 110 | gc(isNum(x)? unBox(x) * 1024 / sizeof(cell) : CELLS); // kB 111 | return x; 112 | } 113 | 114 | /* Construct a cell */ 115 | any cons(any x, any y) { 116 | cell *p; 117 | 118 | if (!(p = Avail)) { 119 | cell c1, c2; 120 | 121 | Push(c1,x); 122 | Push(c2,y); 123 | gc(CELLS); 124 | drop(c1); 125 | p = Avail; 126 | } 127 | Avail = p->car; 128 | p->car = x; 129 | p->cdr = y; 130 | return p; 131 | } 132 | 133 | /* Construct a symbol */ 134 | any consSym(any val, word w) { 135 | cell *p; 136 | 137 | if (!(p = Avail)) { 138 | cell c1; 139 | 140 | if (!val) 141 | gc(CELLS); 142 | else { 143 | Push(c1,val); 144 | gc(CELLS); 145 | drop(c1); 146 | } 147 | p = Avail; 148 | } 149 | Avail = p->car; 150 | p = symPtr(p); 151 | val(p) = val ?: p; 152 | tail(p) = txt(w); 153 | return p; 154 | } 155 | 156 | /* Construct a name cell */ 157 | any consName(word w, any n) { 158 | cell *p; 159 | 160 | if (!(p = Avail)) { 161 | gc(CELLS); 162 | p = Avail; 163 | } 164 | Avail = p->car; 165 | p = symPtr(p); 166 | val(p) = n; 167 | tail(p) = (any)w; 168 | return p; 169 | } 170 | -------------------------------------------------------------------------------- /src/gen3m.c: -------------------------------------------------------------------------------- 1 | /* 13sep16abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include 6 | #include 7 | #include 8 | 9 | typedef unsigned long word; 10 | typedef unsigned char byte; 11 | 12 | #undef bool 13 | typedef enum {NO,YES} bool; 14 | 15 | #define txt(n) (n << 1| 1) 16 | #define box(n) (n << 2| 2) 17 | 18 | #define Nil (1 << 2) 19 | #define T (5 << 2) 20 | #define Quote (7 << 2) 21 | 22 | static int Bits, Chr, RomIx, RamIx; 23 | static char **Rom, **Ram; 24 | static char Token[1024]; 25 | 26 | static int read0(bool); 27 | static char Delim[] = " \t\n\r\"'(),[]`~{}"; 28 | 29 | typedef struct symbol { 30 | char *nm; 31 | int val; 32 | struct symbol *less, *more; 33 | } symbol; 34 | 35 | static symbol *Intern, *Transient; 36 | 37 | static byte Ascii6[] = { 38 | 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 39 | 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 40 | 2, 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 4, 6, 41 | 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 8, 51, 10, 53, 42 | 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 43 | 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 44 | 119, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 45 | 42, 44, 46, 48, 50, 52, 54, 56, 58, 60, 62, 121, 123, 125, 127, 0 46 | }; 47 | 48 | static void giveup(char *msg) { 49 | fprintf(stderr, "gen3m: %s\n", msg); 50 | exit(1); 51 | } 52 | 53 | static void noReadMacros(void) { 54 | giveup("Can't support read-macros"); 55 | } 56 | 57 | static void eofErr(void) { 58 | giveup("EOF Overrun"); 59 | } 60 | 61 | static void addList(int *ix, char ***list, char *fmt, long x) { 62 | char buf[40]; 63 | 64 | *list = realloc(*list, (*ix + 1) * sizeof(char*)); 65 | if (x) 66 | sprintf(buf, fmt, x); 67 | (*list)[(*ix)++] = strdup(x? buf : fmt); 68 | } 69 | 70 | static void mkSym(int *ix, char ***list, char *mem, char *name, char *value) { 71 | bool bin; 72 | int i, c, d; 73 | word w; 74 | 75 | bin = NO; 76 | i = (w = Ascii6[*name++ & 127]) & 1? 7 : 6; 77 | while (*name) { 78 | d = (c = Ascii6[*name++ & 127]) & 1? 7 : 6; 79 | 80 | if (i != Bits) 81 | w |= (word)c << i; 82 | if (i + d > Bits) { 83 | if (bin) 84 | addList(&RomIx, &Rom, "(Rom+%d)", RomIx + 2); 85 | else { 86 | addList(ix, list, "(Rom+%d)", RomIx + (ix == &RomIx? 3 : 1)); 87 | addList(ix, list, value, 0); 88 | bin = YES; 89 | } 90 | addList(&RomIx, &Rom, "0x%lx", w); 91 | w = c >> Bits - i; 92 | i -= Bits; 93 | } 94 | i += d; 95 | } 96 | if (bin) { 97 | if (i <= (Bits-2)) 98 | addList(&RomIx, &Rom, "0x%lx", box(w)); 99 | else { 100 | addList(&RomIx, &Rom, "(Rom+%d)", RomIx + 2); 101 | addList(&RomIx, &Rom, "0x%lx", w); 102 | addList(&RomIx, &Rom, "2", 0); 103 | } 104 | } 105 | else if (i > Bits-1) { 106 | addList(ix, list, "(Rom+%d)", RomIx + (ix == &RomIx? 3 : 1)); 107 | addList(ix, list, value, 0); 108 | addList(&RomIx, &Rom, "0x%lx", w); 109 | addList(&RomIx, &Rom, "2", 0); 110 | } 111 | else { 112 | addList(ix, list, "0x%lx", txt(w)); 113 | addList(ix, list, value, 0); 114 | } 115 | } 116 | 117 | static void print(char buf[], int x) { 118 | if (x & 2) 119 | sprintf(buf, "%d", x); 120 | else if ((x >>= 2) > 0) 121 | sprintf(buf, "(Rom+%d)", x); 122 | else 123 | sprintf(buf, "(Ram+%d)", -x); 124 | } 125 | 126 | static int cons(int x, int y) { 127 | int i, ix = RomIx; 128 | char car[40], cdr[40]; 129 | 130 | print(car, x); 131 | print(cdr, y); 132 | for (i = 0; i < RomIx; i += 2) 133 | if (strcmp(car, Rom[i]) == 0 && strcmp(cdr, Rom[i+1]) == 0) 134 | return i << 2; 135 | addList(&RomIx, &Rom, car, 0); 136 | addList(&RomIx, &Rom, cdr, 0); 137 | return ix << 2; 138 | } 139 | 140 | static int romSym(char *name, char *value) { 141 | int ix = RomIx; 142 | 143 | mkSym(&RomIx, &Rom, "(Rom+%d)", name, value); 144 | return ix + 1 << 2; 145 | } 146 | 147 | static int ramSym(char *name, char *value) { 148 | int ix = RamIx; 149 | 150 | mkSym(&RamIx, &Ram, "(Ram+%d)", name, value); 151 | return -(ix + 1) << 2; 152 | } 153 | 154 | static void insert(symbol **tree, char *name, int value) { 155 | symbol *p, **t; 156 | 157 | p = malloc(sizeof(symbol)); 158 | p->nm = strdup(name); 159 | p->val = value; 160 | p->less = p->more = NULL; 161 | for (t = tree; *t; t = strcmp(name, (*t)->nm) >= 0? &(*t)->more : &(*t)->less); 162 | *t = p; 163 | } 164 | 165 | static int lookup(symbol **tree, char *name) { 166 | symbol *p; 167 | int n; 168 | 169 | for (p = *tree; p; p = n > 0? p->more : p->less) 170 | if ((n = strcmp(name, p->nm)) == 0) 171 | return p->val; 172 | return 0; 173 | } 174 | 175 | static int skip(void) { 176 | for (;;) { 177 | if (Chr < 0) 178 | return Chr; 179 | while (Chr <= ' ') { 180 | Chr = getchar(); 181 | if (Chr < 0) 182 | return Chr; 183 | } 184 | if (Chr != '#') 185 | return Chr; 186 | Chr = getchar(); 187 | if (Chr != '{') { 188 | while (Chr != '\n') { 189 | if (Chr < 0) 190 | return Chr; 191 | Chr = getchar(); 192 | } 193 | } 194 | else { 195 | for (;;) { 196 | Chr = getchar(); 197 | if (Chr < 0) 198 | return Chr; 199 | if (Chr == '}' && (Chr = getchar(), Chr == '#')) 200 | break; 201 | } 202 | Chr = getchar(); 203 | } 204 | } 205 | } 206 | 207 | /* Test for escaped characters */ 208 | static bool testEsc(void) { 209 | for (;;) { 210 | if (Chr < 0) 211 | return NO; 212 | if (Chr != '\\') 213 | return YES; 214 | if (Chr = getchar(), Chr != '\n') 215 | return YES; 216 | do 217 | Chr = getchar(); 218 | while (Chr == ' ' || Chr == '\t'); 219 | } 220 | } 221 | 222 | /* Read a list */ 223 | static int rdList(int z) { 224 | int x; 225 | 226 | if (skip() == ')') { 227 | Chr = getchar(); 228 | return Nil; 229 | } 230 | if (Chr == ']') 231 | return Nil; 232 | if (Chr == '~') 233 | noReadMacros(); 234 | if (Chr == '.') { 235 | Chr = getchar(); 236 | x = skip()==')' || Chr==']'? z : read0(NO); 237 | if (skip() == ')') 238 | Chr = getchar(); 239 | else if (Chr != ']') 240 | giveup("Bad dotted pair"); 241 | return x; 242 | } 243 | x = read0(NO); 244 | return cons(x, rdList(z ?: x)); 245 | } 246 | 247 | /* Read one expression */ 248 | static int read0(bool top) { 249 | int x; 250 | word w; 251 | char *p, buf[40]; 252 | 253 | if (skip() < 0) { 254 | if (top) 255 | return Nil; 256 | eofErr(); 257 | } 258 | if (Chr == '(') { 259 | Chr = getchar(); 260 | x = rdList(0); 261 | if (top && Chr == ']') 262 | Chr = getchar(); 263 | return x; 264 | } 265 | if (Chr == '[') { 266 | Chr = getchar(); 267 | x = rdList(0); 268 | if (Chr != ']') 269 | giveup("Super parentheses mismatch"); 270 | Chr = getchar(); 271 | return x; 272 | } 273 | if (Chr == '\'') { 274 | Chr = getchar(); 275 | return cons(Quote, read0(top)); 276 | } 277 | if (Chr == '`') 278 | noReadMacros(); 279 | if (Chr == '"') { 280 | Chr = getchar(); 281 | if (Chr == '"') { 282 | Chr = getchar(); 283 | return Nil; 284 | } 285 | for (p = Token;;) { 286 | if (!testEsc()) 287 | eofErr(); 288 | *p++ = Chr; 289 | if (p == Token+1024) 290 | giveup("Token too long"); 291 | if ((Chr = getchar()) == '"') { 292 | Chr = getchar(); 293 | break; 294 | } 295 | } 296 | *p = '\0'; 297 | if (x = lookup(&Transient, Token)) 298 | return x; 299 | print(buf, -(RamIx + 1) << 2); 300 | insert(&Transient, Token, x = ramSym(Token, buf)); 301 | return x; 302 | } 303 | if (strchr(Delim, Chr)) 304 | giveup("Bad input"); 305 | if (Chr == '\\') 306 | Chr = getchar(); 307 | for (p = Token;;) { 308 | *p++ = Chr; 309 | if (p == Token+1024) 310 | giveup("Token too long"); 311 | Chr = getchar(); 312 | if (strchr(Delim, Chr)) 313 | break; 314 | if (Chr == '\\') 315 | Chr = getchar(); 316 | } 317 | *p = '\0'; 318 | w = strtol(Token, &p, 10); 319 | if (p != Token && *p == '\0') 320 | return box(w); 321 | if (x = lookup(&Intern, Token)) 322 | return x; 323 | insert(&Intern, Token, x = ramSym(Token, "(Rom+1)")); 324 | return x; 325 | } 326 | 327 | int main(int ac, char *av[]) { 328 | int x, ix; 329 | FILE *fp; 330 | char *p, buf[40]; 331 | 332 | if ((ac -= 2) <= 0) 333 | giveup("No input files"); 334 | if ((Bits = atoi(*++av)) == 0) 335 | Bits = (int)sizeof(char*) * 8; 336 | if ((fp = fopen("sym.d", "w")) == NULL) 337 | giveup("Can't create output files"); 338 | insert(&Intern, "NIL", romSym("NIL", "(Rom+1)")); 339 | cons(Nil, Nil); 340 | fprintf(fp, "#define Nil (any)(Rom+1)\n"); 341 | insert(&Intern, "T", romSym("T", "(Rom+5)")); 342 | fprintf(fp, "#define T (any)(Rom+5)\n"); 343 | insert(&Intern, "quote", romSym("quote", "(num(doQuote) + 2)")); 344 | fprintf(fp, "#define Quote (any)(Rom+7)\nany doQuote(any);\n"); 345 | do { 346 | if (!freopen(*++av, "r", stdin)) 347 | giveup("Can't open input file"); 348 | Chr = getchar(); 349 | while ((x = read0(YES)) != Nil) { 350 | if (x & 2 || (x & 4) == 0) 351 | giveup("Symbol expected"); 352 | if (skip() == '[') { // C Identifier 353 | fprintf(fp, "#define "); 354 | for (;;) { 355 | Chr = getchar(); 356 | if (Chr == EOF) 357 | break; 358 | if (Chr == ']') { 359 | Chr = getchar(); 360 | break; 361 | } 362 | putc(Chr, fp); 363 | } 364 | print(buf, x); 365 | fprintf(fp, " (any)%s\n", buf); 366 | } 367 | x >>= 2; 368 | if (skip() == '{') { // Function pointer 369 | for (p = Token;;) { 370 | Chr = getchar(); 371 | if (Chr == EOF) 372 | break; 373 | if (Chr == '}') { 374 | Chr = getchar(); 375 | break; 376 | } 377 | *p++ = Chr; 378 | } 379 | *p = '\0'; 380 | sprintf(buf, "(num(%s) + 2)", Token); 381 | Ram[-x] = strdup(buf); 382 | fprintf(fp, "any %s(any);\n", Token); 383 | } 384 | else { // Value 385 | print(buf, read0(YES)); 386 | if (x > 0) 387 | Rom[x] = strdup(buf); 388 | else 389 | Ram[-x] = strdup(buf); 390 | } 391 | while (skip() == ',') { // Properties 392 | Chr = getchar(); 393 | if (Chr == EOF) 394 | break; 395 | print(buf, read0(YES)); 396 | ix = RomIx; 397 | if (x > 0) { 398 | addList(&RomIx, &Rom, Rom[x-1], 0); 399 | addList(&RomIx, &Rom, buf, 0); 400 | print(buf, ix << 2); 401 | Rom[x-1] = strdup(buf); 402 | } 403 | else { 404 | addList(&RomIx, &Rom, Ram[-x-1], 0); 405 | addList(&RomIx, &Rom, buf, 0); 406 | print(buf, ix << 2); 407 | Ram[-x-1] = strdup(buf); 408 | } 409 | } 410 | } 411 | } while (--ac); 412 | fprintf(fp, "\n#define ROMS %d\n", RomIx); 413 | fprintf(fp, "#define RAMS %d\n", RamIx); 414 | fclose(fp); 415 | if (fp = fopen("rom.d", "w")) { 416 | for (x = 0; x < RomIx; x += 2) 417 | fprintf(fp, "(any)%s, (any)%s,\n", Rom[x], Rom[x+1]); 418 | fclose(fp); 419 | } 420 | if (fp = fopen("ram.d", "w")) { 421 | for (x = 0; x < RamIx; x += 2) 422 | fprintf(fp, "(any)%s, (any)%s,\n", Ram[x], Ram[x+1]); 423 | fclose(fp); 424 | } 425 | return 0; 426 | } 427 | -------------------------------------------------------------------------------- /src/init.s: -------------------------------------------------------------------------------- 1 | # 24nov16abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | ### Main Entry Point ### 5 | main [Main] NIL 6 | 7 | ### System Globals ### 8 | @ [At] NIL 9 | @@ [At2] NIL 10 | @@@ [At3] NIL 11 | This [This] NIL 12 | meth [Meth] {doMeth} 13 | *Dbg [Dbg] NIL 14 | *Scl [Scl] 0 15 | *Class [Class] NIL 16 | ^ [Up] NIL 17 | *Err [Err] NIL 18 | *Msg [Msg] NIL 19 | *Bye [Bye] NIL # Last unremovable symbol 20 | 21 | ### System Functions ### 22 | abs {doAbs} 23 | + {doAdd} 24 | all {doAll} 25 | and {doAnd} 26 | any {doAny} 27 | append {doAppend} 28 | ,((((NIL @X @X)) (((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))) . T) 29 | apply {doApply} 30 | arg {doArg} 31 | args {doArgs} 32 | argv {doArgv} 33 | -> {doArrow} 34 | as {doAs} 35 | asoq {doAsoq} 36 | assoc {doAssoc} 37 | at {doAt} 38 | atom {doAtom} 39 | bind {doBind} 40 | & {doBitAnd} 41 | | {doBitOr} 42 | bit? {doBitQ} 43 | x| {doBitXor} 44 | bool {doBool} 45 | box {doBox} 46 | box? {doBoxQ} 47 | ! {doBreak} 48 | by {doBy} 49 | bye {doBye} 50 | caaar {doCaaar} 51 | caadr {doCaadr} 52 | caar {doCaar} 53 | cadar {doCadar} 54 | cadddr {doCadddr} 55 | caddr {doCaddr} 56 | cadr {doCadr} 57 | car {doCar} 58 | case {doCase} 59 | casq {doCasq} 60 | catch {doCatch} 61 | cdaar {doCdaar} 62 | cdadr {doCdadr} 63 | cdar {doCdar} 64 | cddar {doCddar} 65 | cddddr {doCddddr} 66 | cdddr {doCdddr} 67 | cddr {doCddr} 68 | cdr {doCdr} 69 | char {doChar} 70 | chain {doChain} 71 | chop {doChop} 72 | circ {doCirc} 73 | circ? {doCircQ} 74 | clip {doClip} 75 | cmd {doCmd} 76 | cnt {doCnt} 77 | : {doCol} 78 | con {doCon} 79 | conc {doConc} 80 | cond {doCond} 81 | cons {doCons} 82 | copy {doCopy} 83 | cut {doCut} 84 | date {doDate} 85 | de {doDe} 86 | dec {doDec} 87 | def {doDef} 88 | default {doDefault} 89 | del {doDel} 90 | delete {doDelete} 91 | ,((((@A (@A . @Z) @Z)) ((@A (@X . @Y) (@X . @Z)) (delete @A @Y @Z))) . T) 92 | delq {doDelq} 93 | diff {doDiff} 94 | / {doDiv} 95 | dm {doDm} 96 | do {doDo} 97 | e {doE} 98 | env {doEnv} 99 | eof {doEof} 100 | eol {doEol} 101 | == {doEq} 102 | =0 {doEq0} 103 | =1 {doEq1} 104 | =T {doEqT} 105 | = {doEqual} 106 | eval {doEval} 107 | extra {doExtra} 108 | extract {doExtract} 109 | fifo {doFifo} 110 | fill {doFill} 111 | filter {doFilter} 112 | fin {doFin} 113 | finally {doFinally} 114 | find {doFind} 115 | fish {doFish} 116 | flg? {doFlgQ} 117 | flip {doFlip} 118 | flush {doFlush} 119 | fold {doFold} 120 | for {doFor} 121 | ,((((@N @End) (for @N 1 @End 1)) ((@N @Beg @End) (for @N @Beg @End 1)) ((@N @Beg @End @Step) (equal @N @Beg)) ((@N @Beg @End @Step) (^ @I (box (-> @Beg))) (_for @N @I @End @Step))) . T) 122 | format {doFormat} 123 | from {doFrom} 124 | full {doFull} 125 | fully {doFully} 126 | fun? {doFunQ} 127 | gc {doGc} 128 | >= {doGe} 129 | ge0 {doGe0} 130 | get {doGet} 131 | getl {doGetl} 132 | glue {doGlue} 133 | > {doGt} 134 | gt0 {doGt0} 135 | head {doHead} 136 | heap {doHeap} 137 | ==== {doHide} 138 | idx {doIdx} 139 | if {doIf} 140 | if2 {doIf2} 141 | ifn {doIfn} 142 | in {doIn} 143 | inc {doInc} 144 | index {doIndex} 145 | intern {doIntern} 146 | isa {doIsa} 147 | job {doJob} 148 | last {doLast} 149 | <= {doLe} 150 | le0 {doLe0} 151 | length {doLength} 152 | let {doLet} 153 | let? {doLetQ} 154 | line {doLine} 155 | link {doLink} 156 | list {doList} 157 | lit {doLit} 158 | lst? {doLstQ} 159 | load {doLoad} 160 | loop {doLoop} 161 | low? {doLowQ} 162 | lowc {doLowc} 163 | < {doLt} 164 | lt0 {doLt0} 165 | lup {doLup} 166 | made {doMade} 167 | make {doMake} 168 | map {doMap} 169 | ,((((@V . @L) (^ @Lst (box (apply get (-> @L)))) (_map @V @Lst))) . T) 170 | mapc {doMapc} 171 | mapcan {doMapcan} 172 | mapcar {doMapcar} 173 | mapcon {doMapcon} 174 | maplist {doMaplist} 175 | maps {doMaps} 176 | match {doMatch} 177 | max {doMax} 178 | maxi {doMaxi} 179 | member {doMember} 180 | ,((((@X (@X . @))) ((@X (@ . @Y)) (member @X @Y))) . T) 181 | memq {doMemq} 182 | meta {doMeta} 183 | method {doMethod} 184 | min {doMin} 185 | mini {doMini} 186 | mix {doMix} 187 | mmeq {doMmeq} 188 | * {doMul} 189 | */ {doMulDiv} 190 | name {doName} 191 | nand {doNand} 192 | n== {doNEq} 193 | n0 {doNEq0} 194 | nT {doNEqT} 195 | <> {doNEqual} 196 | need {doNeed} 197 | new {doNew} 198 | next {doNext} 199 | nil {doNil} 200 | ,((((@X) (^ @ (not (-> @X))))) . T) 201 | nond {doNond} 202 | nor {doNor} 203 | not {doNot} 204 | ,(((@P (1 (-> @P)) T (fail)) (@P)) . T) 205 | nth {doNth} 206 | num? {doNumQ} 207 | off {doOff} 208 | offset {doOffset} 209 | on {doOn} 210 | one {doOne} 211 | onOff {doOnOff} 212 | opt {doOpt} 213 | or {doOr} 214 | ,(((@L (^ @C (box (-> @L))) (_or @C))) . T) 215 | out {doOut} 216 | pack {doPack} 217 | pair {doPair} 218 | pass {doPass} 219 | path {doPath} 220 | pat? {doPatQ} 221 | peek {doPeek} 222 | pick {doPick} 223 | pop {doPop} 224 | ++ {doPopq} 225 | pre? {doPreQ} 226 | prin {doPrin} 227 | prinl {doPrinl} 228 | print {doPrint} 229 | println {doPrintln} 230 | printsp {doPrintsp} 231 | prior {doPrior} 232 | prog {doProg} 233 | prog1 {doProg1} 234 | prog2 {doProg2} 235 | prop {doProp} 236 | :: {doPropCol} 237 | prove {doProve} 238 | push {doPush} 239 | push1 {doPush1} 240 | push1q {doPush1q} 241 | put {doPut} 242 | putl {doPutl} 243 | queue {doQueue} 244 | quit {doQuit} 245 | rand {doRand} 246 | range {doRange} 247 | rank {doRank} 248 | rassoc {doRassoc} 249 | read {doRead} 250 | % {doRem} 251 | replace {doReplace} 252 | rest {doRest} 253 | reverse {doReverse} 254 | rot {doRot} 255 | run {doRun} 256 | sect {doSect} 257 | seed {doSeed} 258 | seek {doSeek} 259 | ; {doSemicol} 260 | send {doSend} 261 | set {doSet} 262 | =: {doSetCol} 263 | setq {doSetq} 264 | >> {doShift} 265 | size {doSize} 266 | skip {doSkip} 267 | sort {doSort} 268 | space {doSpace} 269 | split {doSplit} 270 | sp? {doSpQ} 271 | sqrt {doSqrt} 272 | state {doState} 273 | stem {doStem} 274 | str {doStr} 275 | strip {doStrip} 276 | str? {doStrQ} 277 | - {doSub} 278 | sum {doSum} 279 | super {doSuper} 280 | swap {doSwap} 281 | sym {doSym} 282 | sym? {doSymQ} 283 | t {doT} 284 | tail {doTail} 285 | text {doText} 286 | throw {doThrow} 287 | till {doTill} 288 | $ {doTrace} 289 | trim {doTrim} 290 | try {doTry} 291 | type {doType} 292 | unify {doUnify} 293 | unless {doUnless} 294 | until {doUntil} 295 | up {doUp} 296 | upp? {doUppQ} 297 | uppc {doUppc} 298 | use {doUse} 299 | val {doVal} 300 | ,((((@V . @L) (^ @V (apply get (-> @L))) T)) . T) 301 | when {doWhen} 302 | while {doWhile} 303 | with {doWith} 304 | xchg {doXchg} 305 | xor {doXor} 306 | yoke {doYoke} 307 | zap {doZap} 308 | zero {doZero} 309 | -------------------------------------------------------------------------------- /src/io.c: -------------------------------------------------------------------------------- 1 | /* 05oct14abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | static any read0(bool); 8 | 9 | static int StrI; 10 | static cell StrCell, *StrP; 11 | static word StrW; 12 | static void (*PutSave)(int); 13 | static char Delim[] = " \t\n\r\"'(),[]`~{}"; 14 | 15 | static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));} 16 | static void eofErr(void) {err(NULL, NULL, "EOF Overrun");} 17 | 18 | /* Buffer size */ 19 | int bufSize(any x) {return symBytes(x) + 1;} 20 | 21 | int pathSize(any x) { 22 | int c = firstByte(x); 23 | 24 | if (c != '@' && (c != '+' || secondByte(x) != '@')) 25 | return bufSize(x); 26 | if (!Home) 27 | return symBytes(x); 28 | return strlen(Home) + symBytes(x); 29 | } 30 | 31 | void bufString(any x, char *p) { 32 | int c, i; 33 | word w; 34 | 35 | if (!isNil(x)) { 36 | for (x = name(x), c = getByte1(&i, &w, &x); c; c = getByte(&i, &w, &x)) { 37 | if (c == '^') { 38 | if ((c = getByte(&i, &w, &x)) == '?') 39 | c = 127; 40 | else 41 | c &= 0x1F; 42 | } 43 | *p++ = c; 44 | } 45 | } 46 | *p = '\0'; 47 | } 48 | 49 | void pathString(any x, char *p) { 50 | int c, i; 51 | word w; 52 | char *h; 53 | 54 | x = name(x); 55 | if ((c = getByte1(&i, &w, &x)) == '+') 56 | *p++ = c, c = getByte(&i, &w, &x); 57 | if (c != '@') 58 | while (*p++ = c) 59 | c = getByte(&i, &w, &x); 60 | else { 61 | if (h = Home) 62 | do 63 | *p++ = *h++; 64 | while (*h); 65 | while (*p++ = getByte(&i, &w, &x)); 66 | } 67 | } 68 | 69 | // (path 'any) -> sym 70 | any doPath(any x) { 71 | x = evSym(cdr(x)); 72 | { 73 | char nm[pathSize(x)]; 74 | 75 | pathString(x,nm); 76 | return mkStr(nm); 77 | } 78 | } 79 | 80 | void rdOpen(any ex, any x, inFrame *f) { 81 | NeedSymb(ex,x); 82 | if (isNil(x)) 83 | f->fp = stdin; 84 | else { 85 | char nm[pathSize(x)]; 86 | 87 | pathString(x,nm); 88 | if (nm[0] == '+') { 89 | if (!(f->fp = fopen(nm+1, "a+"))) 90 | openErr(ex, nm); 91 | fseek(f->fp, 0L, SEEK_SET); 92 | } 93 | else if (!(f->fp = fopen(nm, "r"))) 94 | openErr(ex, nm); 95 | } 96 | } 97 | 98 | void wrOpen(any ex, any x, outFrame *f) { 99 | NeedSymb(ex,x); 100 | if (isNil(x)) 101 | f->fp = stdout; 102 | else { 103 | char nm[pathSize(x)]; 104 | 105 | pathString(x,nm); 106 | if (nm[0] == '+') { 107 | if (!(f->fp = fopen(nm+1, "a"))) 108 | openErr(ex, nm); 109 | } 110 | else if (!(f->fp = fopen(nm, "w"))) 111 | openErr(ex, nm); 112 | } 113 | } 114 | 115 | /*** Reading ***/ 116 | void getStdin(void) {Chr = getc(InFile);} 117 | 118 | static void getParse(void) { 119 | if ((Chr = getByte(&Env.parser->i, &Env.parser->w, &Env.parser->nm)) == 0) 120 | Chr = ']'; 121 | } 122 | 123 | void pushInFiles(inFrame *f) { 124 | f->next = Chr, Chr = 0; 125 | InFile = f->fp; 126 | f->get = Env.get, Env.get = getStdin; 127 | f->link = Env.inFrames, Env.inFrames = f; 128 | } 129 | 130 | void pushOutFiles(outFrame *f) { 131 | OutFile = f->fp; 132 | f->put = Env.put, Env.put = putStdout; 133 | f->link = Env.outFrames, Env.outFrames = f; 134 | } 135 | 136 | void popInFiles(void) { 137 | if (InFile != stdin) 138 | fclose(InFile); 139 | Chr = Env.inFrames->next; 140 | Env.get = Env.inFrames->get; 141 | InFile = (Env.inFrames = Env.inFrames->link)? Env.inFrames->fp : stdin; 142 | } 143 | 144 | void popOutFiles(void) { 145 | if (OutFile != stdout && OutFile != stderr) 146 | fclose(OutFile); 147 | Env.put = Env.outFrames->put; 148 | OutFile = (Env.outFrames = Env.outFrames->link)? Env.outFrames->fp : stdout; 149 | } 150 | 151 | /* Skip White Space and Comments */ 152 | static int skipc(int c) { 153 | if (Chr < 0) 154 | return Chr; 155 | for (;;) { 156 | while (Chr <= ' ') { 157 | Env.get(); 158 | if (Chr < 0) 159 | return Chr; 160 | } 161 | if (Chr != c) 162 | return Chr; 163 | Env.get(); 164 | while (Chr != '\n') { 165 | if (Chr < 0) 166 | return Chr; 167 | Env.get(); 168 | } 169 | } 170 | } 171 | 172 | static void comment(void) { 173 | Env.get(); 174 | if (Chr != '{') { 175 | while (Chr != '\n') { 176 | if (Chr < 0) 177 | return; 178 | Env.get(); 179 | } 180 | } 181 | else { 182 | for (;;) { // #{block-comment}# from Kriangkrai Soatthiyanont 183 | Env.get(); 184 | if (Chr < 0) 185 | return; 186 | if (Chr == '}' && (Env.get(), Chr == '#')) 187 | break; 188 | } 189 | Env.get(); 190 | } 191 | } 192 | 193 | static int skip(void) { 194 | for (;;) { 195 | if (Chr < 0) 196 | return Chr; 197 | while (Chr <= ' ') { 198 | Env.get(); 199 | if (Chr < 0) 200 | return Chr; 201 | } 202 | if (Chr != '#') 203 | return Chr; 204 | comment(); 205 | } 206 | } 207 | 208 | /* Test for escaped characters */ 209 | static bool testEsc(void) { 210 | for (;;) { 211 | if (Chr < 0) 212 | return NO; 213 | if (Chr != '\\') 214 | return YES; 215 | if (Env.get(), Chr != '\n') 216 | return YES; 217 | do 218 | Env.get(); 219 | while (Chr == ' ' || Chr == '\t'); 220 | } 221 | } 222 | 223 | /* Read a list */ 224 | static any rdList(void) { 225 | any x; 226 | cell c1; 227 | 228 | for (;;) { 229 | if (skip() == ')') { 230 | Env.get(); 231 | return Nil; 232 | } 233 | if (Chr == ']') 234 | return Nil; 235 | if (Chr != '~') { 236 | Push(c1, x = cons(read0(NO),Nil)); 237 | break; 238 | } 239 | Env.get(); 240 | Push(c1, read0(NO)); 241 | if (isCell(x = data(c1) = EVAL(data(c1)))) { 242 | while (isCell(cdr(x))) 243 | x = cdr(x); 244 | break; 245 | } 246 | drop(c1); 247 | } 248 | for (;;) { 249 | if (skip() == ')') { 250 | Env.get(); 251 | break; 252 | } 253 | if (Chr == ']') 254 | break; 255 | if (Chr == '.') { 256 | Env.get(); 257 | cdr(x) = skip()==')' || Chr==']'? data(c1) : read0(NO); 258 | if (skip() == ')') 259 | Env.get(); 260 | else if (Chr != ']') 261 | err(NULL, x, "Bad dotted pair"); 262 | break; 263 | } 264 | if (Chr != '~') 265 | x = cdr(x) = cons(read0(NO),Nil); 266 | else { 267 | Env.get(); 268 | cdr(x) = read0(NO); 269 | cdr(x) = EVAL(cdr(x)); 270 | while (isCell(cdr(x))) 271 | x = cdr(x); 272 | } 273 | } 274 | return Pop(c1); 275 | } 276 | 277 | /* Try for anonymous symbol */ 278 | static any anonymous(any s) { 279 | int c, i; 280 | word w; 281 | unsigned long n; 282 | heap *h; 283 | 284 | if ((c = getByte1(&i, &w, &s)) != '$') 285 | return NULL; 286 | n = 0; 287 | while (c = getByte(&i, &w, &s)) { 288 | if (c < '0' || c > '9') 289 | return NULL; 290 | n = n * 10 + c - '0'; 291 | } 292 | n *= sizeof(cell); 293 | h = Heaps; 294 | do 295 | if ((any)n > h->cells && (any)n < h->cells + CELLS) 296 | return symPtr((any)n); 297 | while (h = h->next); 298 | return NULL; 299 | } 300 | 301 | /* Read one expression */ 302 | static any read0(bool top) { 303 | int i; 304 | word w; 305 | any x, y; 306 | cell c1, *p; 307 | 308 | if (skip() < 0) { 309 | if (top) 310 | return Nil; 311 | eofErr(); 312 | } 313 | if (Chr == '(') { 314 | Env.get(); 315 | x = rdList(); 316 | if (top && Chr == ']') 317 | Env.get(); 318 | return x; 319 | } 320 | if (Chr == '[') { 321 | Env.get(); 322 | x = rdList(); 323 | if (Chr != ']') 324 | err(NULL, x, "Super parentheses mismatch"); 325 | Env.get(); 326 | return x; 327 | } 328 | if (Chr == '\'') { 329 | Env.get(); 330 | return cons(Quote, read0(top)); 331 | } 332 | if (Chr == ',') { 333 | Env.get(); 334 | return read0(top); 335 | } 336 | if (Chr == '`') { 337 | Env.get(); 338 | Push(c1, read0(top)); 339 | x = EVAL(data(c1)); 340 | drop(c1); 341 | return x; 342 | } 343 | if (Chr == '"') { 344 | Env.get(); 345 | if (Chr == '"') { 346 | Env.get(); 347 | return Nil; 348 | } 349 | if (!testEsc()) 350 | eofErr(); 351 | putByte1(Chr, &i, &w, &p); 352 | while (Env.get(), Chr != '"') { 353 | if (!testEsc()) 354 | eofErr(); 355 | putByte(Chr, &i, &w, &p, &c1); 356 | } 357 | y = popSym(i, w, p, &c1), Env.get(); 358 | if (x = isIntern(tail(y), Transient)) 359 | return x; 360 | intern(y, Transient); 361 | return y; 362 | } 363 | if (strchr(Delim, Chr)) 364 | err(NULL, NULL, "Bad input '%c' (%d)", isprint(Chr)? Chr:'?', Chr); 365 | if (Chr == '\\') 366 | Env.get(); 367 | putByte1(Chr, &i, &w, &p); 368 | for (;;) { 369 | Env.get(); 370 | if (strchr(Delim, Chr)) 371 | break; 372 | if (Chr == '\\') 373 | Env.get(); 374 | putByte(Chr, &i, &w, &p, &c1); 375 | } 376 | y = popSym(i, w, p, &c1); 377 | if (x = symToNum(tail(y), (int)unBox(val(Scl)), '.', 0)) 378 | return x; 379 | if (x = anonymous(name(y))) 380 | return x; 381 | if (x = isIntern(tail(y), Intern)) 382 | return x; 383 | intern(y, Intern); 384 | val(y) = Nil; 385 | return y; 386 | } 387 | 388 | any read1(int end) { 389 | if (!Chr) 390 | Env.get(); 391 | if (Chr == end) 392 | return Nil; 393 | return read0(YES); 394 | } 395 | 396 | /* Read one token */ 397 | any token(any x, int c) { 398 | int i; 399 | word w; 400 | any y; 401 | cell c1, *p; 402 | 403 | if (!Chr) 404 | Env.get(); 405 | if (skipc(c) < 0) 406 | return Nil; 407 | if (Chr == '"') { 408 | Env.get(); 409 | if (Chr == '"') { 410 | Env.get(); 411 | return Nil; 412 | } 413 | if (!testEsc()) 414 | return Nil; 415 | Push(c1, y = cons(mkChar(Chr), Nil)); 416 | while (Env.get(), Chr != '"' && testEsc()) 417 | y = cdr(y) = cons(mkChar(Chr), Nil); 418 | Env.get(); 419 | return Pop(c1); 420 | } 421 | if (Chr >= '0' && Chr <= '9') { 422 | putByte1(Chr, &i, &w, &p); 423 | while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.') 424 | putByte(Chr, &i, &w, &p, &c1); 425 | return symToNum(tail(popSym(i, w, p, &c1)), (int)unBox(val(Scl)), '.', 0); 426 | } 427 | if (Chr != '+' && Chr != '-') { 428 | char nm[bufSize(x)]; 429 | 430 | bufString(x, nm); 431 | if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) { 432 | if (Chr == '\\') 433 | Env.get(); 434 | putByte1(Chr, &i, &w, &p); 435 | while (Env.get(), 436 | Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' || 437 | Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) { 438 | if (Chr == '\\') 439 | Env.get(); 440 | putByte(Chr, &i, &w, &p, &c1); 441 | } 442 | y = popSym(i, w, p, &c1); 443 | if (x = isIntern(tail(y), Intern)) 444 | return x; 445 | intern(y, Intern); 446 | val(y) = Nil; 447 | return y; 448 | } 449 | } 450 | y = mkTxt(c = Chr); 451 | Env.get(); 452 | return mkChar(c); 453 | } 454 | 455 | // (read ['sym1 ['sym2]]) -> any 456 | any doRead(any ex) { 457 | any x, y; 458 | 459 | if (!isCell(x = cdr(ex))) 460 | x = read1(0); 461 | else { 462 | y = EVAL(car(x)); 463 | NeedSym(ex,y); 464 | x = cdr(x), x = EVAL(car(x)); 465 | NeedSym(ex,x); 466 | x = token(y, firstByte(x)); 467 | } 468 | if (InFile == stdin && Chr == '\n') 469 | Chr = 0; 470 | return x; 471 | } 472 | 473 | // (peek) -> sym 474 | any doPeek(any ex __attribute__((unused))) { 475 | if (!Chr) 476 | Env.get(); 477 | return Chr<0? Nil : mkChar(Chr); 478 | } 479 | 480 | // (char) -> sym 481 | // (char 'num) -> sym 482 | // (char 'sym) -> num 483 | any doChar(any ex) { 484 | any x = cdr(ex); 485 | 486 | if (!isCell(x)) { 487 | if (!Chr) 488 | Env.get(); 489 | x = Chr<0? Nil : mkChar(Chr); 490 | Env.get(); 491 | return x; 492 | } 493 | if (isNum(x = EVAL(car(x)))) { 494 | int c = (int)unBox(x); 495 | 496 | if (c == 0) 497 | return Nil; 498 | if (c == 127) 499 | return mkChar2('^','?'); 500 | if (c < ' ') 501 | return mkChar2('^', c + 0x40); 502 | return mkChar(c); 503 | } 504 | if (isSym(x)) { 505 | int c; 506 | 507 | if ((c = firstByte(x)) != '^') 508 | return box(c); 509 | return box((c = secondByte(x)) == '?'? 127 : c & 0x1F); 510 | } 511 | atomError(ex,x); 512 | } 513 | 514 | // (skip ['any]) -> sym 515 | any doSkip(any x) { 516 | x = evSym(cdr(x)); 517 | return skipc(firstByte(x))<0? Nil : mkChar(Chr); 518 | } 519 | 520 | // (eol) -> flg 521 | any doEol(any ex __attribute__((unused))) { 522 | return InFile && Chr=='\n' || Chr<=0? T : Nil; 523 | } 524 | 525 | // (eof ['flg]) -> flg 526 | any doEof(any x) { 527 | x = cdr(x); 528 | if (!isNil(EVAL(car(x)))) { 529 | Chr = -1; 530 | return T; 531 | } 532 | if (!Chr) 533 | Env.get(); 534 | return Chr < 0? T : Nil; 535 | } 536 | 537 | // (from 'any ..) -> sym 538 | any doFrom(any x) { 539 | int i, j, ac = length(x = cdr(x)), p[ac]; 540 | cell c[ac]; 541 | char *av[ac]; 542 | 543 | if (ac == 0) 544 | return Nil; 545 | for (i = 0;;) { 546 | Push(c[i], evSym(x)); 547 | av[i] = alloc(NULL, bufSize(data(c[i]))), bufString(data(c[i]), av[i]); 548 | p[i] = 0; 549 | if (++i == ac) 550 | break; 551 | x = cdr(x); 552 | } 553 | if (!Chr) 554 | Env.get(); 555 | while (Chr >= 0) { 556 | for (i = 0; i < ac; ++i) { 557 | for (;;) { 558 | if (av[i][p[i]] == (byte)Chr) { 559 | if (av[i][++p[i]]) 560 | break; 561 | Env.get(); 562 | x = data(c[i]); 563 | goto done; 564 | } 565 | if (!p[i]) 566 | break; 567 | for (j = 1; --p[i]; ++j) 568 | if (memcmp(av[i], av[i]+j, p[i]) == 0) 569 | break; 570 | } 571 | } 572 | Env.get(); 573 | } 574 | x = Nil; 575 | done: 576 | i = 0; do 577 | free(av[i]); 578 | while (++i < ac); 579 | drop(c[0]); 580 | return x; 581 | } 582 | 583 | // (till 'any ['flg]) -> lst|sym 584 | any doTill(any ex) { 585 | any x; 586 | int i; 587 | word w; 588 | cell c1; 589 | 590 | x = evSym(cdr(ex)); 591 | { 592 | char buf[bufSize(x)]; 593 | 594 | bufString(x, buf); 595 | if (!Chr) 596 | Env.get(); 597 | if (Chr < 0 || strchr(buf,Chr)) 598 | return Nil; 599 | x = cddr(ex); 600 | if (isNil(EVAL(car(x)))) { 601 | Push(c1, x = cons(mkChar(Chr), Nil)); 602 | while (Env.get(), Chr > 0 && !strchr(buf,Chr)) 603 | x = cdr(x) = cons(mkChar(Chr), Nil); 604 | return Pop(c1); 605 | } 606 | putByte1(Chr, &i, &w, &x); 607 | while (Env.get(), Chr > 0 && !strchr(buf,Chr)) 608 | putByte(Chr, &i, &w, &x, &c1); 609 | return popSym(i, w, x, &c1); 610 | } 611 | } 612 | 613 | static inline bool eol(void) { 614 | if (Chr < 0) 615 | return YES; 616 | if (Chr == '\n') { 617 | Chr = 0; 618 | return YES; 619 | } 620 | if (Chr == '\r') { 621 | Env.get(); 622 | if (Chr == '\n') 623 | Chr = 0; 624 | return YES; 625 | } 626 | return NO; 627 | } 628 | 629 | // (line 'flg) -> lst|sym 630 | any doLine(any x) { 631 | any y; 632 | int i; 633 | word w; 634 | cell c1; 635 | 636 | if (!Chr) 637 | Env.get(); 638 | if (eol()) 639 | return Nil; 640 | x = cdr(x); 641 | if (isNil(EVAL(car(x)))) { 642 | Push(c1, cons(mkChar(Chr), Nil)); 643 | y = data(c1); 644 | for (;;) { 645 | if (Env.get(), eol()) 646 | return Pop(c1); 647 | y = cdr(y) = cons(mkChar(Chr), Nil); 648 | } 649 | } 650 | else { 651 | putByte1(Chr, &i, &w, &y); 652 | for (;;) { 653 | if (Env.get(), eol()) 654 | return popSym(i, w, y, &c1); 655 | putByte(Chr, &i, &w, &y, &c1); 656 | } 657 | } 658 | } 659 | 660 | static any parse(any x, bool skp) { 661 | int c; 662 | parseFrame *save, parser; 663 | void (*getSave)(void); 664 | cell c1; 665 | 666 | save = Env.parser; 667 | Env.parser = &parser; 668 | parser.nm = name(parser.sym = x); 669 | getSave = Env.get, Env.get = getParse, c = Chr; 670 | Push(c1, Env.parser->sym); 671 | Chr = getByte1(&parser.i, &parser.w, &parser.nm); 672 | if (skp) 673 | getParse(); 674 | x = rdList(); 675 | drop(c1); 676 | Chr = c, Env.get = getSave, Env.parser = save; 677 | return x; 678 | } 679 | 680 | static void putString(int c) { 681 | putByte(c, &StrI, &StrW, &StrP, &StrCell); 682 | } 683 | 684 | void begString(void) { 685 | putByte0(&StrI, &StrW, &StrP); 686 | PutSave = Env.put, Env.put = putString; 687 | } 688 | 689 | any endString(void) { 690 | Env.put = PutSave; 691 | StrP = popSym(StrI, StrW, StrP, &StrCell); 692 | return StrI? StrP : Nil; 693 | } 694 | 695 | // (any 'sym) -> any 696 | any doAny(any ex) { 697 | any x; 698 | 699 | x = cdr(ex), x = EVAL(car(x)); 700 | NeedSymb(ex,x); 701 | if (!isNil(x)) { 702 | int c; 703 | parseFrame *save, parser; 704 | void (*getSave)(void); 705 | cell c1; 706 | 707 | save = Env.parser; 708 | Env.parser = &parser; 709 | parser.nm = name(parser.sym = x); 710 | getSave = Env.get, Env.get = getParse, c = Chr; 711 | Push(c1, Env.parser->sym); 712 | Chr = getByte1(&parser.i, &parser.w, &parser.nm); 713 | x = read0(YES); 714 | drop(c1); 715 | Chr = c, Env.get = getSave, Env.parser = save; 716 | } 717 | return x; 718 | } 719 | 720 | // (sym 'any) -> sym 721 | any doSym(any x) { 722 | x = EVAL(cadr(x)); 723 | begString(); 724 | print(x); 725 | return endString(); 726 | } 727 | 728 | // (str 'sym) -> lst 729 | // (str 'lst) -> sym 730 | any doStr(any ex) { 731 | any x; 732 | 733 | x = cdr(ex); 734 | if (isNum(x = EVAL(car(x)))) 735 | argError(ex,x); 736 | if (isSym(x)) 737 | return isNil(x)? Nil : parse(x,NO); 738 | begString(); 739 | while (print(car(x)), isCell(x = cdr(x))) 740 | space(); 741 | return endString(); 742 | } 743 | 744 | any load(any ex, int pr, any x) { 745 | cell c1, c2; 746 | inFrame f; 747 | 748 | if (isSymb(x) && firstByte(x) == '-') { 749 | Push(c1, parse(x,YES)); 750 | x = evList(data(c1)); 751 | drop(c1); 752 | return x; 753 | } 754 | rdOpen(ex, x, &f); 755 | pushInFiles(&f); 756 | doHide(Nil); 757 | x = Nil; 758 | for (;;) { 759 | if (InFile != stdin) 760 | data(c1) = read1(0); 761 | else { 762 | if (pr && !Chr) 763 | Env.put(pr), space(), fflush(OutFile); 764 | data(c1) = read1('\n'); 765 | while (Chr > 0) { 766 | if (Chr == '\n') { 767 | Chr = 0; 768 | break; 769 | } 770 | if (Chr == '#') 771 | comment(); 772 | else { 773 | if (Chr > ' ') 774 | break; 775 | Env.get(); 776 | } 777 | } 778 | } 779 | if (isNil(data(c1))) { 780 | popInFiles(); 781 | doHide(Nil); 782 | return x; 783 | } 784 | Save(c1); 785 | if (InFile != stdin || Chr || !pr) 786 | x = EVAL(data(c1)); 787 | else { 788 | Push(c2, val(At)); 789 | x = val(At) = EVAL(data(c1)); 790 | val(At3) = val(At2), val(At2) = data(c2); 791 | outString("-> "), fflush(OutFile), print(x), newline(); 792 | } 793 | drop(c1); 794 | } 795 | } 796 | 797 | // (load 'any ..) -> any 798 | any doLoad(any ex) { 799 | any x, y; 800 | 801 | x = cdr(ex); 802 | do { 803 | if ((y = EVAL(car(x))) != T) 804 | y = load(ex, '>', y); 805 | else 806 | y = loadAll(ex); 807 | } while (isCell(x = cdr(x))); 808 | return y; 809 | } 810 | 811 | // (in 'any . prg) -> any 812 | any doIn(any ex) { 813 | any x; 814 | inFrame f; 815 | 816 | x = cdr(ex), x = EVAL(car(x)); 817 | rdOpen(ex,x,&f); 818 | pushInFiles(&f); 819 | x = prog(cddr(ex)); 820 | popInFiles(); 821 | return x; 822 | } 823 | 824 | // (out 'any . prg) -> any 825 | any doOut(any ex) { 826 | any x; 827 | outFrame f; 828 | 829 | x = cdr(ex), x = EVAL(car(x)); 830 | wrOpen(ex,x,&f); 831 | pushOutFiles(&f); 832 | x = prog(cddr(ex)); 833 | popOutFiles(); 834 | return x; 835 | } 836 | 837 | /*** Prining ***/ 838 | void putStdout(int c) {putc(c, OutFile);} 839 | 840 | void newline(void) {Env.put('\n');} 841 | void space(void) {Env.put(' ');} 842 | 843 | void outString(char *s) { 844 | while (*s) 845 | Env.put(*s++); 846 | } 847 | 848 | int bufNum(char buf[BITS/2], long n) { 849 | return sprintf(buf, "%ld", n); 850 | } 851 | 852 | void outNum(long n) { 853 | char buf[BITS/2]; 854 | 855 | bufNum(buf, n); 856 | outString(buf); 857 | } 858 | 859 | void prIntern(any nm) { 860 | int i, c; 861 | word w; 862 | 863 | c = getByte1(&i, &w, &nm); 864 | if (strchr(Delim, c)) 865 | Env.put('\\'); 866 | Env.put(c); 867 | while (c = getByte(&i, &w, &nm)) { 868 | if (c == '\\' || strchr(Delim, c)) 869 | Env.put('\\'); 870 | Env.put(c); 871 | } 872 | } 873 | 874 | void prTransient(any nm) { 875 | int i, c; 876 | word w; 877 | 878 | Env.put('"'); 879 | c = getByte1(&i, &w, &nm); 880 | do { 881 | if (c == '"' || c == '\\') 882 | Env.put('\\'); 883 | Env.put(c); 884 | } while (c = getByte(&i, &w, &nm)); 885 | Env.put('"'); 886 | } 887 | 888 | /* Print one expression */ 889 | void print(any x) { 890 | if (isNum(x)) 891 | outNum(unBox(x)); 892 | else if (isSym(x)) { 893 | any nm = name(x); 894 | 895 | if (nm == txt(0)) 896 | Env.put('$'), outNum((word)x/sizeof(cell)); 897 | else if (x == isIntern(nm, Intern)) 898 | prIntern(nm); 899 | else 900 | prTransient(nm); 901 | } 902 | else if (car(x) == Quote && x != cdr(x)) 903 | Env.put('\''), print(cdr(x)); 904 | else { 905 | any y; 906 | 907 | Env.put('('); 908 | if ((y = circ(x)) == NULL) { 909 | while (print(car(x)), !isNil(x = cdr(x))) { 910 | if (!isCell(x)) { 911 | outString(" . "); 912 | print(x); 913 | break; 914 | } 915 | space(); 916 | } 917 | } 918 | else if (y == x) { 919 | do 920 | print(car(x)), space(); 921 | while (y != (x = cdr(x))); 922 | Env.put('.'); 923 | } 924 | else { 925 | do 926 | print(car(x)), space(); 927 | while (y != (x = cdr(x))); 928 | outString(". ("); 929 | do 930 | print(car(x)), space(); 931 | while (y != (x = cdr(x))); 932 | outString(".)"); 933 | } 934 | Env.put(')'); 935 | } 936 | } 937 | 938 | void prin(any x) { 939 | if (!isNil(x)) { 940 | if (isNum(x)) 941 | outNum(unBox(x)); 942 | else if (isSym(x)) { 943 | int i, c; 944 | word w; 945 | 946 | for (x = name(x), c = getByte1(&i, &w, &x); c; c = getByte(&i, &w, &x)) { 947 | if (c != '^') 948 | Env.put(c); 949 | else if (!(c = getByte(&i, &w, &x))) 950 | Env.put('^'); 951 | else if (c == '?') 952 | Env.put(127); 953 | else 954 | Env.put(c &= 0x1F); 955 | } 956 | } 957 | else { 958 | while (prin(car(x)), !isNil(x = cdr(x))) { 959 | if (!isCell(x)) { 960 | prin(x); 961 | break; 962 | } 963 | } 964 | } 965 | } 966 | } 967 | 968 | // (prin 'any ..) -> any 969 | any doPrin(any x) { 970 | any y = Nil; 971 | 972 | while (isCell(x = cdr(x))) 973 | prin(y = EVAL(car(x))); 974 | return y; 975 | } 976 | 977 | // (prinl 'any ..) -> any 978 | any doPrinl(any x) { 979 | any y = Nil; 980 | 981 | while (isCell(x = cdr(x))) 982 | prin(y = EVAL(car(x))); 983 | newline(); 984 | return y; 985 | } 986 | 987 | // (space ['num]) -> num 988 | any doSpace(any ex) { 989 | any x; 990 | int n; 991 | 992 | if (isNil(x = EVAL(cadr(ex)))) { 993 | Env.put(' '); 994 | return One; 995 | } 996 | for (n = xNum(ex,x); n > 0; --n) 997 | Env.put(' '); 998 | return x; 999 | } 1000 | 1001 | // (print 'any ..) -> any 1002 | any doPrint(any x) { 1003 | any y; 1004 | 1005 | x = cdr(x), print(y = EVAL(car(x))); 1006 | while (isCell(x = cdr(x))) 1007 | space(), print(y = EVAL(car(x))); 1008 | return y; 1009 | } 1010 | 1011 | // (printsp 'any ..) -> any 1012 | any doPrintsp(any x) { 1013 | any y; 1014 | 1015 | x = cdr(x); 1016 | do 1017 | print(y = EVAL(car(x))), space(); 1018 | while (isCell(x = cdr(x))); 1019 | return y; 1020 | } 1021 | 1022 | // (println 'any ..) -> any 1023 | any doPrintln(any x) { 1024 | any y; 1025 | 1026 | x = cdr(x), print(y = EVAL(car(x))); 1027 | while (isCell(x = cdr(x))) 1028 | space(), print(y = EVAL(car(x))); 1029 | newline(); 1030 | return y; 1031 | } 1032 | 1033 | // (flush) -> flg 1034 | any doFlush(any ex __attribute__((unused))) { 1035 | return fflush(OutFile)? Nil : T; 1036 | } 1037 | -------------------------------------------------------------------------------- /src/lib.s: -------------------------------------------------------------------------------- 1 | # 15jul15abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | macro ("Prg" 5 | (run (fill "Prg")) ) 6 | 7 | recur (recurse 8 | (run (cdr recurse)) ) 9 | 10 | curry ("Z" 11 | (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) 12 | (if2 "P" (diff "X" "P") 13 | (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) 14 | (cons "Y" (fill "Z" "P")) 15 | (list "Y" (cons 'job (lit (env @)) "Z")) 16 | (cons "Y" "Z") ) ) ) 17 | 18 | ### Definitions ### 19 | undef (("X" "C") 20 | (when (pair "X") 21 | (setq "C" (cdr "X") "X" (car "X")) ) 22 | (ifn "C" 23 | (prog1 (val "X") (set "X")) 24 | (prog1 25 | (cdr (asoq "X" (val "C"))) 26 | (set "C" 27 | (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) 28 | 29 | redef ("Lst" 30 | (let ("Old" (car "Lst") "New" (name "Old")) 31 | (set 32 | "New" (val "Old") 33 | "Old" "New" 34 | "Old" (fill (cdr "Lst") "Old") ) 35 | "New" ) ) 36 | 37 | daemon (("X" . Prg) 38 | (prog1 39 | (if (pair "X") 40 | (method (car "X") (cdr "X")) 41 | (or (pair (getd "X")) (expr "X")) ) 42 | (con @ (append Prg (cdr @))) ) ) 43 | 44 | patch (("Lst" "Pat" . "Prg") 45 | (bind (fish pat? "Pat") 46 | (recur ("Lst") 47 | (loop 48 | (cond 49 | ((match "Pat" (car "Lst")) 50 | (set "Lst" (run "Prg")) ) 51 | ((pair (car "Lst")) 52 | (recurse @) ) ) 53 | (NIL (cdr "Lst")) 54 | (T (atom (cdr "Lst")) 55 | (when (match "Pat" (cdr "Lst")) 56 | (con "Lst" (run "Prg")) ) ) 57 | (setq "Lst" (cdr "Lst")) ) ) ) ) 58 | 59 | ### I/O ### 60 | tab ((Lst . @) 61 | (for N Lst 62 | (let V (next) 63 | (and (gt0 N) (space (- N (length V)))) 64 | (prin V) 65 | (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) 66 | (prinl) ) 67 | 68 | msg ((X . @) 69 | (out NIL 70 | (print X) 71 | (pass prinl) 72 | (flush) ) 73 | X ) 74 | 75 | script ((File . @) 76 | (load File) ) 77 | 78 | ### List ### 79 | insert ((N Lst X) 80 | (conc 81 | (cut (dec N) 'Lst) 82 | (cons X) 83 | Lst ) ) 84 | 85 | remove ((N Lst) 86 | (conc 87 | (cut (dec N) 'Lst) 88 | (cdr Lst) ) ) 89 | 90 | place ((N Lst X) 91 | (conc 92 | (cut (dec N) 'Lst) 93 | (cons X) 94 | (cdr Lst) ) ) 95 | 96 | uniq ((Lst) 97 | (let R NIL 98 | (filter 99 | '((X) (not (idx 'R X T))) 100 | Lst ) ) ) 101 | 102 | group ((Lst) 103 | (make 104 | (for X Lst 105 | (if (assoc (car X) (made)) 106 | (conc @ (cons (cdr X))) 107 | (link (list (car X) (cdr X))) ) ) ) ) 108 | 109 | ### OOP ### 110 | class (Lst 111 | (let L (val (setq *Class (car Lst))) 112 | (def *Class 113 | (recur (L) 114 | (if (atom (car L)) 115 | (cdr Lst) 116 | (cons (car L) (recurse (cdr L))) ) ) ) ) ) 117 | 118 | object (("Sym" "Val" . @) 119 | (putl "Sym") 120 | (def "Sym" "Val") 121 | (while (args) 122 | (put "Sym" (next) (next)) ) 123 | "Sym" ) 124 | 125 | extend (X 126 | (setq *Class (car X)) ) 127 | 128 | # Class variables 129 | var (X 130 | (if (pair (car X)) 131 | (put (cdar X) (caar X) (cdr X)) 132 | (put *Class (car X) (cdr X)) ) ) 133 | 134 | var: (X 135 | (apply meta X This) ) 136 | 137 | ### Math ### 138 | scl (("N" . "Prg") 139 | (if "Prg" 140 | (let *Scl "N" (run "Prg")) 141 | (setq *Scl "N") ) ) 142 | 143 | ### Pretty Printing ### 144 | pretty ((X N) 145 | (setq N (abs (space (or N 0)))) 146 | (while (and (pair X) (== 'quote (car X))) 147 | (prin "'") 148 | (pop 'X) ) 149 | (cond 150 | ((atom X) (print X)) 151 | ((memq (car X) '(de dm)) 152 | (_pretty 153 | (spPrt (pop 'X)) 154 | (spPrt (pop 'X)) 155 | (prtty1 X N Z) ) ) 156 | ((memq (car X) '(let let?)) 157 | (_pretty 158 | (cond 159 | ((atom (car X)) 160 | (spPrt (pop 'X)) 161 | (prtty? (pop 'X) N) ) 162 | ((>= 12 (size (car X))) 163 | (prin " (") 164 | (let Z (pop 'X) 165 | (prtty2 Z NIL Z) ) 166 | (prin ")") ) 167 | (T 168 | (nlPrt N) 169 | (prin "(") 170 | (let Z (pop 'X) 171 | (prtty2 Z (+ N 3) Z) ) 172 | (prin " )") ) ) 173 | (prtty1 X N Z) ) ) 174 | ((== 'for (car X)) 175 | (_pretty 176 | (cond 177 | ((or (atom (car X)) (atom (cdar X))) 178 | (spPrt (pop 'X)) 179 | (prtty? (pop 'X) N) ) 180 | ((>= 12 (size (car X))) 181 | (spPrt (pop 'X)) ) 182 | (T 183 | (nlPrt N) 184 | (prtty0 (pop 'X) (+ 3 N)) ) ) 185 | (prtty1 X N Z) ) ) 186 | ((== 'if2 (car X)) 187 | (_pretty 188 | (when (>= 12 (size (head 2 X))) 189 | (spPrt (pop 'X)) 190 | (spPrt (pop 'X)) ) 191 | (prtty1 X N Z) ) ) 192 | ((memq (car X) '(while until do state finally co)) 193 | (prtty3 X N) ) 194 | ((>= 12 (size X)) 195 | (ifn (memq (car X) '(set setq default)) 196 | (print X) 197 | (prin "(") 198 | (let Z X 199 | (printsp (pop 'X)) 200 | (prtty2 X NIL Z) ) 201 | (prin ")") ) ) 202 | ((memq (car X) '(=: use later recur tab new)) 203 | (_pretty 204 | (space) 205 | (print (pop 'X)) 206 | (prtty1 X N Z) ) ) 207 | ((memq (car X) '(set setq default)) 208 | (_pretty 209 | (if (cdddr X) 210 | (prog 211 | (nlPrt N) 212 | (prtty2 X N Z) ) 213 | (spPrt (pop 'X)) 214 | (nlPrt1 (pop 'X) N) ) ) ) 215 | ((memq (car X) '(T NIL ! if ifn when unless case casq with catch push bind job in out ctl)) 216 | (prtty3 X N) ) 217 | (T (prtty0 X N)) ) ) 218 | 219 | _pretty ("Prg" 220 | (prin "(") 221 | (let Z X 222 | (print (pop 'X)) 223 | (run "Prg") ) 224 | (prin " )") ) 225 | 226 | prtty0 ((X N) 227 | (prin "(") 228 | (let Z X 229 | (pretty (pop 'X) (- -3 N)) 230 | (prtty1 X N Z) ) 231 | (prin " )") ) 232 | 233 | prtty1 ((X N Z) 234 | (loop 235 | (NIL X) 236 | (T (== Z X) (prin " .")) 237 | (T (atom X) (prin " . ") (print X)) 238 | (nlPrt1 (pop 'X) N) ) ) 239 | 240 | prtty2 ((X N Z) 241 | (loop 242 | (print (pop 'X)) 243 | (NIL X) 244 | (T (== Z X) (prin " .")) 245 | (T (atom X) (prin " . ") (print X)) 246 | (if N 247 | (prtty? (pop 'X) N) 248 | (space) 249 | (print (pop 'X)) ) 250 | (NIL X) 251 | (T (== Z X) (prin " .")) 252 | (T (atom X) (prin " . ") (print X)) 253 | (if N 254 | (nlPrt N) 255 | (space 2) ) ) ) 256 | 257 | prtty3 ((X N) 258 | (prin "(") 259 | (let Z X 260 | (print (pop 'X)) 261 | (when (or (atom (car X)) (>= 12 (size (car X)))) 262 | (spPrt (pop 'X)) ) 263 | (when X 264 | (prtty1 X N Z) 265 | (space) ) ) 266 | (prin ")") ) 267 | 268 | prtty? ((X N) 269 | (ifn (or (atom X) (>= 12 (size X))) 270 | (nlPrt1 X N) 271 | (spPrt X) ) ) 272 | 273 | spPrt ((X) 274 | (space) 275 | (print X) ) 276 | 277 | nlPrt ((N) 278 | (prinl) 279 | (space (+ 3 N)) ) 280 | 281 | nlPrt1 ((X N) 282 | (prinl) 283 | (pretty X (+ 3 N)) ) 284 | 285 | pp (("X" C) 286 | (let *Dbg NIL 287 | (pretty 288 | (if (or C (pair "X")) 289 | (cons 'dm "X" 290 | (if (pair "X") 291 | (method (car "X") (cdr "X")) 292 | (method "X" C) ) ) 293 | (cons 'de "X" (val "X")) ) ) 294 | (prinl) 295 | "X" ) ) 296 | 297 | show (("X" . @) 298 | (let *Dbg NIL 299 | (setq "X" (pass get "X")) 300 | (when (sym? "X") 301 | (print "X" (val "X")) 302 | (prinl) 303 | (maps 304 | '((X) 305 | (space 3) 306 | (if (atom X) 307 | (println X) 308 | (println (cdr X) (car X)) ) ) 309 | "X" ) ) 310 | "X" ) ) 311 | ,((((@X) (^ @ (show (-> @X))))) . T) 312 | 313 | view ((X L) 314 | (let (Z X *Dbg) 315 | (loop 316 | (T (atom X) (println X)) 317 | (if (atom (car X)) 318 | (println '+-- (pop 'X)) 319 | (print '+---) 320 | (view 321 | (pop 'X) 322 | (append L (cons (if X "| " " "))) ) ) 323 | (NIL X) 324 | (mapc prin L) 325 | (T (== Z X) (println '*)) 326 | (println '|) 327 | (mapc prin L) ) ) ) 328 | 329 | # vi:et:ts=3:sw=3 330 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | /* 12jul15abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | /* Globals */ 8 | int Chr, Trace; 9 | char **AV, *AV0, *Home; 10 | heap *Heaps; 11 | cell *Avail; 12 | stkEnv Env; 13 | catchFrame *CatchPtr; 14 | FILE *InFile, *OutFile; 15 | any TheKey, TheCls, Thrown; 16 | any Intern[2], Transient[2]; 17 | any ApplyArgs, ApplyBody; 18 | 19 | /* ROM Data */ 20 | any const __attribute__ ((__aligned__(2*WORD))) Rom[] = { 21 | #include "rom.d" 22 | }; 23 | 24 | /* RAM Symbols */ 25 | any __attribute__ ((__aligned__(2*WORD))) Ram[] = { 26 | #include "ram.d" 27 | }; 28 | 29 | static bool Jam; 30 | static jmp_buf ErrRst; 31 | 32 | 33 | /*** System ***/ 34 | void giveup(char *msg) { 35 | fprintf(stderr, "%s\n", msg); 36 | exit(1); 37 | } 38 | 39 | void bye(int n) { 40 | static bool b; 41 | 42 | if (!b) { 43 | b = YES; 44 | unwind(NULL); 45 | prog(val(Bye)); 46 | } 47 | exit(n); 48 | } 49 | 50 | void execError(char *s) { 51 | fprintf(stderr, "%s: Can't exec\n", s); 52 | exit(127); 53 | } 54 | 55 | /* Allocate memory */ 56 | void *alloc(void *p, size_t siz) { 57 | if (!(p = realloc(p,siz))) 58 | giveup("No memory"); 59 | return p; 60 | } 61 | 62 | /* Allocate cell heap */ 63 | void heapAlloc(void) { 64 | heap *h; 65 | cell *p; 66 | 67 | h = (heap*)((long)alloc(NULL, sizeof(heap) + sizeof(cell)) + (sizeof(cell)-1) & ~(sizeof(cell)-1)); 68 | h->next = Heaps, Heaps = h; 69 | p = h->cells + CELLS-1; 70 | do 71 | Free(p); 72 | while (--p >= h->cells); 73 | } 74 | 75 | // (heap 'flg) -> num 76 | any doHeap(any x) { 77 | long n = 0; 78 | 79 | x = cdr(x); 80 | if (isNil(EVAL(car(x)))) { 81 | heap *h = Heaps; 82 | do 83 | n += CELLS; 84 | while (h = h->next); 85 | } 86 | else 87 | for (x = Avail; x; x = car(x)) 88 | ++n; 89 | return box(n * sizeof(cell) / 1024); // kB 90 | } 91 | 92 | // (env ['lst] | ['sym 'val] ..) -> lst 93 | any doEnv(any x) { 94 | int i; 95 | bindFrame *p; 96 | cell c1, c2; 97 | 98 | Push(c1,Nil); 99 | if (!isCell(x = cdr(x))) { 100 | for (p = Env.bind; p; p = p->link) { 101 | if (p->i == 0) { 102 | for (i = p->cnt; --i >= 0;) { 103 | for (x = data(c1); ; x = cdr(x)) { 104 | if (!isCell(x)) { 105 | data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1)); 106 | break; 107 | } 108 | if (caar(x) == p->bnd[i].sym) 109 | break; 110 | } 111 | } 112 | } 113 | } 114 | } 115 | else { 116 | do { 117 | Push(c2, EVAL(car(x))); 118 | if (isCell(data(c2))) { 119 | do 120 | data(c1) = cons( 121 | isCell(car(data(c2)))? 122 | cons(caar(data(c2)), cdar(data(c2))) : 123 | cons(car(data(c2)), val(car(data(c2)))), 124 | data(c1) ); 125 | while (isCell(data(c2) = cdr(data(c2)))); 126 | } 127 | else if (!isNil(data(c2))) { 128 | x = cdr(x); 129 | data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1)); 130 | } 131 | drop(c2); 132 | } 133 | while (isCell(x = cdr(x))); 134 | } 135 | return Pop(c1); 136 | } 137 | 138 | // (up [cnt] sym ['val]) -> any 139 | any doUp(any x) { 140 | any y, *val; 141 | int cnt, i; 142 | bindFrame *p; 143 | 144 | x = cdr(x); 145 | if (!isNum(y = car(x))) 146 | cnt = 1; 147 | else 148 | cnt = (int)unBox(y), x = cdr(x), y = car(x); 149 | for (p = Env.bind, val = &val(y); p; p = p->link) { 150 | if (p->i <= 0) { 151 | for (i = 0; i < p->cnt; ++i) 152 | if (p->bnd[i].sym == y) { 153 | if (!--cnt) { 154 | if (isCell(x = cdr(x))) 155 | return p->bnd[i].val = EVAL(car(x)); 156 | return p->bnd[i].val; 157 | } 158 | val = &p->bnd[i].val; 159 | } 160 | } 161 | } 162 | if (isCell(x = cdr(x))) 163 | return *val = EVAL(car(x)); 164 | return *val; 165 | } 166 | 167 | /*** Primitives ***/ 168 | any circ(any x) { 169 | any y; 170 | 171 | if (!isCell(x) || x >= (any)Rom && x < (any)(Rom+ROMS)) 172 | return NULL; 173 | for (y = x;;) { 174 | any z = cdr(y); 175 | 176 | *(word*)&cdr(y) |= 1; 177 | if (!isCell(y = z)) { 178 | do 179 | *(word*)&cdr(x) &= ~1; 180 | while (isCell(x = cdr(x))); 181 | return NULL; 182 | } 183 | if (y >= (any)Rom && y < (any)(Rom+ROMS)) { 184 | do 185 | *(word*)&cdr(x) &= ~1; 186 | while (y != (x = cdr(x))); 187 | return NULL; 188 | } 189 | if (num(cdr(y)) & 1) { 190 | while (x != y) 191 | *(word*)&cdr(x) &= ~1, x = cdr(x); 192 | do 193 | *(word*)&cdr(x) &= ~1; 194 | while (y != (x = cdr(x))); 195 | return y; 196 | } 197 | } 198 | } 199 | 200 | /* Comparisons */ 201 | bool equal(any x, any y) { 202 | any a, b; 203 | bool res; 204 | 205 | if (x == y) 206 | return YES; 207 | if (isNum(x)) 208 | return NO; 209 | if (isSym(x)) { 210 | if (!isSymb(y)) 211 | return NO; 212 | if ((x = name(x)) == (y = name(y))) 213 | return x != txt(0); 214 | if (isTxt(x) || isTxt(y)) 215 | return NO; 216 | do { 217 | if (num(tail(x)) != num(tail(y))) 218 | return NO; 219 | x = val(x), y = val(y); 220 | } while (!isNum(x) && !isNum(y)); 221 | return x == y; 222 | } 223 | if (!isCell(y)) 224 | return NO; 225 | a = x, b = y; 226 | res = NO; 227 | for (;;) { 228 | if (!equal(car(x), (any)(num(car(y)) & ~1))) 229 | break; 230 | if (!isCell(cdr(x))) { 231 | res = equal(cdr(x), cdr(y)); 232 | break; 233 | } 234 | if (!isCell(cdr(y))) 235 | break; 236 | if (x < (any)Rom || x >= (any)(Rom+ROMS)) 237 | *(word*)&car(x) |= 1; 238 | x = cdr(x), y = cdr(y); 239 | if (num(car(x)) & 1) { 240 | for (;;) { 241 | if (a == x) { 242 | if (b == y) { 243 | for (;;) { 244 | a = cdr(a); 245 | if ((b = cdr(b)) == y) { 246 | res = a == x; 247 | break; 248 | } 249 | if (a == x) { 250 | res = YES; 251 | break; 252 | } 253 | } 254 | } 255 | break; 256 | } 257 | if (b == y) { 258 | res = NO; 259 | break; 260 | } 261 | *(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b); 262 | } 263 | do 264 | *(word*)&car(a) &= ~1, a = cdr(a); 265 | while (a != x); 266 | return res; 267 | } 268 | } 269 | while (a != x && (a < (any)Rom || a >= (any)(Rom+ROMS))) 270 | *(word*)&car(a) &= ~1, a = cdr(a); 271 | return res; 272 | } 273 | 274 | long compare(any x, any y) { 275 | any a, b; 276 | 277 | if (x == y) 278 | return 0; 279 | if (isNil(x)) 280 | return -1; 281 | if (x == T) 282 | return +1; 283 | if (isNum(x)) { 284 | if (!isNum(y)) 285 | return isNil(y)? +1 : -1; 286 | return num(x) - num(y); 287 | } 288 | if (isSym(x)) { 289 | int c, d, i, j; 290 | word w, v; 291 | 292 | if (isNum(y) || isNil(y)) 293 | return +1; 294 | if (isCell(y) || y == T) 295 | return -1; 296 | a = name(x), b = name(y); 297 | if (a == txt(0) && b == txt(0)) 298 | return (long)x - (long)y; 299 | if ((c = getByte1(&i, &w, &a)) == (d = getByte1(&j, &v, &b))) 300 | do 301 | if (c == 0) 302 | return 0; 303 | while ((c = getByte(&i, &w, &a)) == (d = getByte(&j, &v, &b))); 304 | return c - d; 305 | } 306 | if (!isCell(y)) 307 | return y == T? -1 : +1; 308 | a = x, b = y; 309 | for (;;) { 310 | long n; 311 | 312 | if (n = compare(car(x),car(y))) 313 | return n; 314 | if (!isCell(x = cdr(x))) 315 | return compare(x, cdr(y)); 316 | if (!isCell(y = cdr(y))) 317 | return y == T? -1 : +1; 318 | if (x == a && y == b) 319 | return 0; 320 | } 321 | } 322 | 323 | /*** Error handling ***/ 324 | void err(any ex, any x, char *fmt, ...) { 325 | va_list ap; 326 | char msg[240]; 327 | outFrame f; 328 | 329 | Chr = 0; 330 | Env.brk = NO; 331 | f.fp = stderr; 332 | pushOutFiles(&f); 333 | while (*AV && strcmp(*AV,"-") != 0) 334 | ++AV; 335 | if (ex) 336 | outString("!? "), print(val(Up) = ex), newline(); 337 | if (x) 338 | print(x), outString(" -- "); 339 | va_start(ap,fmt); 340 | vsnprintf(msg, sizeof(msg), fmt, ap); 341 | va_end(ap); 342 | if (msg[0]) { 343 | outString(msg), newline(); 344 | val(Msg) = mkStr(msg); 345 | if (!isNil(val(Err)) && !Jam) 346 | Jam = YES, prog(val(Err)), Jam = NO; 347 | load(NULL, '?', Nil); 348 | } 349 | unwind(NULL); 350 | Env.stack = NULL; 351 | Env.next = -1; 352 | Env.make = Env.yoke = NULL; 353 | Env.parser = NULL; 354 | Trace = 0; 355 | Env.put = putStdout; 356 | Env.get = getStdin; 357 | longjmp(ErrRst, +1); 358 | } 359 | 360 | // (quit ['any ['any]]) 361 | any doQuit(any x) { 362 | any y; 363 | 364 | x = cdr(x), y = evSym(x); 365 | { 366 | char msg[bufSize(y)]; 367 | 368 | bufString(y, msg); 369 | x = isCell(x = cdr(x))? EVAL(car(x)) : NULL; 370 | err(NULL, x, "%s", msg); 371 | } 372 | } 373 | 374 | void argError(any ex, any x) {err(ex, x, "Bad argument");} 375 | void numError(any ex, any x) {err(ex, x, "Number expected");} 376 | void symError(any ex, any x) {err(ex, x, "Symbol expected");} 377 | void pairError(any ex, any x) {err(ex, x, "Cons pair expected");} 378 | void atomError(any ex, any x) {err(ex, x, "Atom expected");} 379 | void lstError(any ex, any x) {err(ex, x, "List expected");} 380 | void varError(any ex, any x) {err(ex, x, "Variable expected");} 381 | void protError(any ex, any x) {err(ex, x, "Protected symbol");} 382 | 383 | void unwind(catchFrame *catch) { 384 | any x; 385 | int i, j, n; 386 | bindFrame *p; 387 | catchFrame *q; 388 | 389 | while (q = CatchPtr) { 390 | while (p = Env.bind) { 391 | if ((i = p->i) < 0) { 392 | j = i, n = 0; 393 | while (++n, ++j && (p = p->link)) 394 | if (p->i >= 0 || p->i < i) 395 | --j; 396 | do { 397 | for (p = Env.bind, j = n; --j; p = p->link); 398 | if (p->i < 0 && ((p->i -= i) > 0? (p->i = 0) : p->i) == 0) 399 | for (j = p->cnt; --j >= 0;) { 400 | x = val(p->bnd[j].sym); 401 | val(p->bnd[j].sym) = p->bnd[j].val; 402 | p->bnd[j].val = x; 403 | } 404 | } while (--n); 405 | } 406 | if (Env.bind == q->env.bind) 407 | break; 408 | if (Env.bind->i == 0) 409 | for (i = Env.bind->cnt; --i >= 0;) 410 | val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; 411 | Env.bind = Env.bind->link; 412 | } 413 | while (Env.inFrames != q->env.inFrames) 414 | popInFiles(); 415 | while (Env.outFrames != q->env.outFrames) 416 | popOutFiles(); 417 | Env = q->env; 418 | EVAL(q->fin); 419 | CatchPtr = q->link; 420 | if (q == catch) 421 | return; 422 | } 423 | while (Env.bind) { 424 | if (Env.bind->i == 0) 425 | for (i = Env.bind->cnt; --i >= 0;) 426 | val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; 427 | Env.bind = Env.bind->link; 428 | } 429 | while (Env.inFrames) 430 | popInFiles(); 431 | while (Env.outFrames) 432 | popOutFiles(); 433 | } 434 | 435 | /*** Evaluation ***/ 436 | any evExpr(any expr, any x) { 437 | any y = car(expr); 438 | struct { // bindFrame 439 | struct bindFrame *link; 440 | int i, cnt; 441 | struct {any sym; any val;} bnd[length(y)+2]; 442 | } f; 443 | 444 | f.link = Env.bind, Env.bind = (bindFrame*)&f; 445 | f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1; 446 | f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 447 | while (isCell(y)) { 448 | f.bnd[f.cnt].sym = car(y); 449 | f.bnd[f.cnt].val = EVAL(car(x)); 450 | ++f.cnt, x = cdr(x), y = cdr(y); 451 | } 452 | if (isNil(y)) { 453 | do { 454 | x = val(f.bnd[--f.i].sym); 455 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 456 | f.bnd[f.i].val = x; 457 | } while (f.i); 458 | x = prog(cdr(expr)); 459 | } 460 | else if (y != At) { 461 | f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; 462 | do { 463 | x = val(f.bnd[--f.i].sym); 464 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 465 | f.bnd[f.i].val = x; 466 | } while (f.i); 467 | x = prog(cdr(expr)); 468 | } 469 | else { 470 | int n, cnt; 471 | cell *arg; 472 | cell c[n = cnt = length(x)]; 473 | 474 | while (--n >= 0) 475 | Push(c[n], EVAL(car(x))), x = cdr(x); 476 | do { 477 | x = val(f.bnd[--f.i].sym); 478 | val(f.bnd[f.i].sym) = f.bnd[f.i].val; 479 | f.bnd[f.i].val = x; 480 | } while (f.i); 481 | n = Env.next, Env.next = cnt; 482 | arg = Env.arg, Env.arg = c; 483 | x = prog(cdr(expr)); 484 | if (cnt) 485 | drop(c[cnt-1]); 486 | Env.arg = arg, Env.next = n; 487 | } 488 | while (--f.cnt >= 0) 489 | val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 490 | Env.bind = f.link; 491 | return x; 492 | } 493 | 494 | void undefined(any x, any ex) {err(ex, x, "Undefined");} 495 | 496 | static any evList2(any foo, any ex) { 497 | cell c1; 498 | 499 | Push(c1, foo); 500 | if (isCell(foo)) { 501 | foo = evExpr(foo, cdr(ex)); 502 | drop(c1); 503 | return foo; 504 | } 505 | for (;;) { 506 | if (isNil(val(foo))) 507 | undefined(foo,ex); 508 | if (isNum(foo = val(foo))) { 509 | foo = evSubr(foo,ex); 510 | drop(c1); 511 | return foo; 512 | } 513 | if (isCell(foo)) { 514 | foo = evExpr(foo, cdr(ex)); 515 | drop(c1); 516 | return foo; 517 | } 518 | } 519 | } 520 | 521 | /* Evaluate a list */ 522 | any evList(any ex) { 523 | any foo; 524 | 525 | if (isNum(foo = car(ex))) 526 | return ex; 527 | if (isCell(foo)) { 528 | if (isNum(foo = evList(foo))) 529 | return evSubr(foo,ex); 530 | return evList2(foo,ex); 531 | } 532 | for (;;) { 533 | if (isNil(val(foo))) 534 | undefined(foo,ex); 535 | if (isNum(foo = val(foo))) 536 | return evSubr(foo,ex); 537 | if (isCell(foo)) 538 | return evExpr(foo, cdr(ex)); 539 | } 540 | } 541 | 542 | /* Evaluate number */ 543 | long evNum(any ex, any x) {return xNum(ex, EVAL(car(x)));} 544 | 545 | long xNum(any ex, any x) { 546 | NeedNum(ex,x); 547 | return unBox(x); 548 | } 549 | 550 | /* Evaluate any to sym */ 551 | any evSym(any x) {return xSym(EVAL(car(x)));} 552 | 553 | any xSym(any x) { 554 | int i; 555 | word w; 556 | any y; 557 | cell c1, c2; 558 | 559 | if (isSymb(x)) 560 | return x; 561 | Push(c1,x); 562 | putByte0(&i, &w, &y); 563 | i = 0, pack(x, &i, &w, &y, &c2); 564 | y = popSym(i, w, y, &c2); 565 | drop(c1); 566 | return i? y : Nil; 567 | } 568 | 569 | // (args) -> flg 570 | any doArgs(any ex __attribute__((unused))) { 571 | return Env.next > 0? T : Nil; 572 | } 573 | 574 | // (next) -> any 575 | any doNext(any ex __attribute__((unused))) { 576 | if (Env.next > 0) 577 | return data(Env.arg[--Env.next]); 578 | if (Env.next == 0) 579 | Env.next = -1; 580 | return Nil; 581 | } 582 | 583 | // (arg ['cnt]) -> any 584 | any doArg(any ex) { 585 | long n; 586 | 587 | if (Env.next < 0) 588 | return Nil; 589 | if (!isCell(cdr(ex))) 590 | return data(Env.arg[Env.next]); 591 | if ((n = evNum(ex,cdr(ex))) > 0 && n <= Env.next) 592 | return data(Env.arg[Env.next - n]); 593 | return Nil; 594 | } 595 | 596 | // (rest) -> lst 597 | any doRest(any x) { 598 | int i; 599 | cell c1; 600 | 601 | if ((i = Env.next) <= 0) 602 | return Nil; 603 | Push(c1, x = cons(data(Env.arg[--i]), Nil)); 604 | while (i) 605 | x = cdr(x) = cons(data(Env.arg[--i]), Nil); 606 | return Pop(c1); 607 | } 608 | 609 | any mkDat(int y, int m, int d) { 610 | int n; 611 | static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31}; 612 | 613 | if (y<0 || m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400)) 614 | return Nil; 615 | n = (12*y + m - 3) / 12; 616 | return box((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d); 617 | } 618 | 619 | // (date 'dat) -> (y m d) 620 | // (date 'y 'm 'd) -> dat | NIL 621 | // (date '(y m d)) -> dat | NIL 622 | any doDate(any ex) { 623 | any x, z; 624 | int y, m, d, n; 625 | cell c1; 626 | 627 | x = cdr(ex); 628 | if (isNil(z = EVAL(car(x)))) 629 | return Nil; 630 | if (isCell(z)) 631 | return mkDat(xNum(ex, car(z)), xNum(ex, cadr(z)), xNum(ex, caddr(z))); 632 | if (!isCell(x = cdr(x))) { 633 | if ((n = xNum(ex,z)) < 0) 634 | return Nil; 635 | y = (100*n - 20) / 3652425; 636 | n += (y - y/4); 637 | y = (100*n - 20) / 36525; 638 | n -= 36525*y / 100; 639 | m = (10*n - 5) / 306; 640 | d = (10*n - 306*m + 5) / 10; 641 | if (m < 10) 642 | m += 3; 643 | else 644 | ++y, m -= 9; 645 | Push(c1, cons(box(d), Nil)); 646 | data(c1) = cons(box(m), data(c1)); 647 | data(c1) = cons(box(y), data(c1)); 648 | return Pop(c1); 649 | } 650 | y = xNum(ex,z); 651 | m = evNum(ex,x); 652 | return mkDat(y, m, evNum(ex,cdr(x))); 653 | } 654 | 655 | // (cmd ['any]) -> sym 656 | any doCmd(any x) { 657 | if (isNil(x = evSym(cdr(x)))) 658 | return mkStr(AV0); 659 | bufString(x, AV0); 660 | return x; 661 | } 662 | 663 | // (argv [var ..] [. sym]) -> lst|sym 664 | any doArgv(any ex) { 665 | any x, y; 666 | char **p; 667 | cell c1; 668 | 669 | if (*(p = AV) && strcmp(*p,"-") == 0) 670 | ++p; 671 | if (isNil(x = cdr(ex))) { 672 | if (!*p) 673 | return Nil; 674 | Push(c1, x = cons(mkStr(*p++), Nil)); 675 | while (*p) 676 | x = cdr(x) = cons(mkStr(*p++), Nil); 677 | return Pop(c1); 678 | } 679 | do { 680 | if (!isCell(x)) { 681 | NeedSymb(ex,x); 682 | CheckVar(ex,x); 683 | if (!*p) 684 | return val(x) = Nil; 685 | Push(c1, y = cons(mkStr(*p++), Nil)); 686 | while (*p) 687 | y = cdr(y) = cons(mkStr(*p++), Nil); 688 | return val(x) = Pop(c1); 689 | } 690 | y = car(x); 691 | NeedVar(ex,y); 692 | CheckVar(ex,y); 693 | val(y) = *p? mkStr(*p++) : Nil; 694 | } while (!isNil(x = cdr(x))); 695 | return val(y); 696 | } 697 | 698 | // (opt) -> sym 699 | any doOpt(any ex __attribute__((unused))) { 700 | return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil; 701 | } 702 | 703 | any loadAll(any ex) { 704 | any x = Nil; 705 | 706 | while (*AV && strcmp(*AV,"-") != 0) 707 | x = load(ex, 0, mkStr(*AV++)); 708 | return x; 709 | } 710 | 711 | /*** Main ***/ 712 | int main(int ac, char *av[]) { 713 | int i; 714 | char *p; 715 | 716 | AV0 = *av++; 717 | AV = av; 718 | heapAlloc(); 719 | Intern[0] = Intern[1] = Transient[0] = Transient[1] = Nil; 720 | intern(Nil, Intern); 721 | intern(T, Intern); 722 | intern(Meth, Intern); 723 | intern(Quote, Intern); // Last protected symbol 724 | for (i = 1; i < RAMS; i += 2) 725 | if (Ram[i] != (any)(Ram + i)) 726 | intern((any)(Ram + i), Intern); 727 | if (ac >= 2 && strcmp(av[ac-2], "+") == 0) 728 | val(Dbg) = T, av[ac-2] = NULL; 729 | if (av[0] && *av[0] != '-' && (p = strrchr(av[0], '/')) && !(p == av[0]+1 && *av[0] == '.')) { 730 | Home = malloc(p - av[0] + 2); 731 | memcpy(Home, av[0], p - av[0] + 1); 732 | Home[p - av[0] + 1] = '\0'; 733 | } 734 | InFile = stdin, Env.get = getStdin; 735 | OutFile = stdout, Env.put = putStdout; 736 | ApplyArgs = cons(cons(consSym(Nil,0), Nil), Nil); 737 | ApplyBody = cons(Nil,Nil); 738 | if (!setjmp(ErrRst)) 739 | prog(val(Main)), loadAll(NULL); 740 | while (!feof(stdin)) 741 | load(NULL, ':', Nil); 742 | bye(0); 743 | } 744 | -------------------------------------------------------------------------------- /src/math.c: -------------------------------------------------------------------------------- 1 | /* 25feb15abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include "pico.h" 6 | 7 | static void divErr(any ex) {err(ex,NULL,"Div/0");} 8 | 9 | /* Number of bytes */ 10 | int numBytes(any x) { 11 | int n = 4; 12 | word w = (word)x >> 2; 13 | 14 | if ((w & 0xFF000000) == 0) { 15 | --n; 16 | if ((w & 0xFF0000) == 0) { 17 | --n; 18 | if ((w & 0xFF00) == 0) 19 | --n; 20 | } 21 | } 22 | return n; 23 | } 24 | 25 | /* Make number from symbol */ 26 | any symToNum(any s, int scl, int sep, int ign) { 27 | unsigned c; 28 | int i; 29 | word w; 30 | bool sign, frac; 31 | long n; 32 | 33 | if (!(c = getByte1(&i, &w, &s))) 34 | return NULL; 35 | while (c <= ' ') /* Skip white space */ 36 | if (!(c = getByte(&i, &w, &s))) 37 | return NULL; 38 | sign = NO; 39 | if (c == '+' || c == '-' && (sign = YES)) 40 | if (!(c = getByte(&i, &w, &s))) 41 | return NULL; 42 | if ((c -= '0') > 9) 43 | return NULL; 44 | frac = NO; 45 | n = c; 46 | while ((c = getByte(&i, &w, &s)) && (!frac || scl)) { 47 | if ((int)c == sep) { 48 | if (frac) 49 | return NULL; 50 | frac = YES; 51 | } 52 | else if ((int)c != ign) { 53 | if ((c -= '0') > 9) 54 | return NULL; 55 | n = n * 10 + c; 56 | if (frac) 57 | --scl; 58 | } 59 | } 60 | if (c) { 61 | if ((c -= '0') > 9) 62 | return NULL; 63 | if (c >= 5) 64 | n += 1; 65 | while (c = getByte(&i, &w, &s)) { 66 | if ((c -= '0') > 9) 67 | return NULL; 68 | } 69 | } 70 | if (frac) 71 | while (--scl >= 0) 72 | n *= 10; 73 | return box(sign? -n : n); 74 | } 75 | 76 | /* Make symbol from number */ 77 | any numToSym(any x, int scl, int sep, int ign) { 78 | int i; 79 | word w; 80 | cell c1; 81 | long n; 82 | byte *p, buf[BITS/2]; 83 | 84 | n = unBox(x); 85 | putByte0(&i, &w, &x); 86 | if (n < 0) { 87 | n = -n; 88 | putByte('-', &i, &w, &x, &c1); 89 | } 90 | for (p = buf;;) { 91 | *p = n % 10; 92 | if ((n /= 10) == 0) 93 | break; 94 | ++p; 95 | } 96 | if ((scl = p - buf - scl) < 0) { 97 | putByte('0', &i, &w, &x, &c1); 98 | putByte(sep, &i, &w, &x, &c1); 99 | while (scl < -1) 100 | putByte('0', &i, &w, &x, &c1), ++scl; 101 | } 102 | for (;;) { 103 | putByte(*p + '0', &i, &w, &x, &c1); 104 | if (--p < buf) 105 | return popSym(i, w, x, &c1); 106 | if (scl == 0) 107 | putByte(sep, &i, &w, &x, &c1); 108 | else if (ign && scl > 0 && scl % 3 == 0) 109 | putByte(ign, &i, &w, &x, &c1); 110 | --scl; 111 | } 112 | } 113 | 114 | // (format 'num ['num ['sym1 ['sym2]]]) -> sym 115 | // (format 'sym ['num ['sym1 ['sym2]]]) -> num 116 | any doFormat(any ex) { 117 | int scl, sep, ign; 118 | any x, y; 119 | cell c1; 120 | 121 | x = cdr(ex), Push(c1, EVAL(car(x))); 122 | NeedAtom(ex,data(c1)); 123 | x = cdr(x), y = EVAL(car(x)); 124 | scl = isNil(y)? 0 : xNum(ex, y); 125 | sep = '.'; 126 | ign = 0; 127 | if (isCell(x = cdr(x))) { 128 | y = EVAL(car(x)); 129 | NeedSymb(ex,y); 130 | sep = firstByte(y); 131 | if (isCell(x = cdr(x))) { 132 | y = EVAL(car(x)); 133 | NeedSymb(ex,y); 134 | ign = firstByte(y); 135 | } 136 | } 137 | data(c1) = isNum(data(c1))? 138 | numToSym(data(c1), scl, sep, ign) : 139 | symToNum(name(data(c1)), scl, sep, ign) ?: Nil; 140 | return Pop(c1); 141 | } 142 | 143 | // (+ 'num ..) -> num 144 | any doAdd(any ex) { 145 | any x, y; 146 | long n; 147 | 148 | x = cdr(ex); 149 | if (isNil(y = EVAL(car(x)))) 150 | return Nil; 151 | NeedNum(ex,y); 152 | n = unBox(y); 153 | while (isCell(x = cdr(x))) { 154 | if (isNil(y = EVAL(car(x)))) 155 | return Nil; 156 | NeedNum(ex,y); 157 | n += unBox(y); 158 | } 159 | return box(n); 160 | } 161 | 162 | // (- 'num ..) -> num 163 | any doSub(any ex) { 164 | any x, y; 165 | long n; 166 | 167 | x = cdr(ex); 168 | if (isNil(y = EVAL(car(x)))) 169 | return Nil; 170 | NeedNum(ex,y); 171 | n = unBox(y); 172 | if (!isCell(x = cdr(x))) 173 | return box(-n); 174 | do { 175 | if (isNil(y = EVAL(car(x)))) 176 | return Nil; 177 | NeedNum(ex,y); 178 | n -= unBox(y); 179 | } while (isCell(x = cdr(x))); 180 | return box(n); 181 | } 182 | 183 | // (inc 'num) -> num 184 | // (inc 'var ['num]) -> num 185 | any doInc(any ex) { 186 | any x, y; 187 | cell c1; 188 | 189 | x = cdr(ex); 190 | if (isNil(data(c1) = EVAL(car(x)))) 191 | return Nil; 192 | if (isNum(data(c1))) 193 | return (any)(num(data(c1)) + 4); 194 | CheckVar(ex,data(c1)); 195 | if (!isCell(x = cdr(x))) { 196 | if (isNil(val(data(c1)))) 197 | return Nil; 198 | NeedNum(ex,val(data(c1))); 199 | val(data(c1)) = (any)(num(val(data(c1))) + 4); 200 | } 201 | else { 202 | Save(c1); 203 | y = EVAL(car(x)); 204 | drop(c1); 205 | if (isNil(val(data(c1))) || isNil(y)) 206 | return Nil; 207 | NeedNum(ex,val(data(c1))); 208 | NeedNum(ex,y); 209 | val(data(c1)) = box(unBox(val(data(c1))) + unBox(y)); 210 | } 211 | return val(data(c1)); 212 | } 213 | 214 | // (dec 'num) -> num 215 | // (dec 'var ['num]) -> num 216 | any doDec(any ex) { 217 | any x, y; 218 | cell c1; 219 | 220 | x = cdr(ex); 221 | if (isNil(data(c1) = EVAL(car(x)))) 222 | return Nil; 223 | if (isNum(data(c1))) 224 | return (any)(num(data(c1)) - 4); 225 | CheckVar(ex,data(c1)); 226 | if (!isCell(x = cdr(x))) { 227 | if (isNil(val(data(c1)))) 228 | return Nil; 229 | NeedNum(ex,val(data(c1))); 230 | val(data(c1)) = (any)(num(val(data(c1))) - 4); 231 | } 232 | else { 233 | Save(c1); 234 | y = EVAL(car(x)); 235 | drop(c1); 236 | if (isNil(val(data(c1))) || isNil(y)) 237 | return Nil; 238 | NeedNum(ex,val(data(c1))); 239 | NeedNum(ex,y); 240 | val(data(c1)) = box(unBox(val(data(c1))) - unBox(y)); 241 | } 242 | return val(data(c1)); 243 | } 244 | 245 | // (* 'num ..) -> num 246 | any doMul(any ex) { 247 | any x, y; 248 | long n; 249 | 250 | x = cdr(ex); 251 | if (isNil(y = EVAL(car(x)))) 252 | return Nil; 253 | NeedNum(ex,y); 254 | n = unBox(y); 255 | while (isCell(x = cdr(x))) { 256 | if (isNil(y = EVAL(car(x)))) 257 | return Nil; 258 | NeedNum(ex,y); 259 | n *= unBox(y); 260 | } 261 | return box(n); 262 | } 263 | 264 | // (*/ 'num1 ['num2 ..] 'num3) -> num 265 | any doMulDiv(any ex) { 266 | any x, y; 267 | long long n; 268 | 269 | x = cdr(ex); 270 | if (isNil(y = EVAL(car(x)))) 271 | return Nil; 272 | NeedNum(ex,y); 273 | n = unBox(y); 274 | for (;;) { 275 | x = cdr(x); 276 | if (isNil(y = EVAL(car(x)))) 277 | return Nil; 278 | NeedNum(ex,y); 279 | if (!isCell(cdr(x))) 280 | break; 281 | n *= unBox(y); 282 | } 283 | if (y == Zero) 284 | divErr(ex); 285 | return box((long)((n + unBox(y)/2) / unBox(y))); 286 | } 287 | 288 | // (/ 'num ..) -> num 289 | any doDiv(any ex) { 290 | any x, y; 291 | long n; 292 | 293 | x = cdr(ex); 294 | if (isNil(y = EVAL(car(x)))) 295 | return Nil; 296 | NeedNum(ex,y); 297 | n = unBox(y); 298 | while (isCell(x = cdr(x))) { 299 | if (isNil(y = EVAL(car(x)))) 300 | return Nil; 301 | NeedNum(ex,y); 302 | if (y == Zero) 303 | divErr(ex); 304 | n /= unBox(y); 305 | } 306 | return box(n); 307 | } 308 | 309 | // (% 'num ..) -> num 310 | any doRem(any ex) { 311 | any x, y; 312 | long n; 313 | 314 | x = cdr(ex); 315 | if (isNil(y = EVAL(car(x)))) 316 | return Nil; 317 | NeedNum(ex,y); 318 | n = unBox(y); 319 | while (isCell(x = cdr(x))) { 320 | if (isNil(y = EVAL(car(x)))) 321 | return Nil; 322 | NeedNum(ex,y); 323 | if (y == Zero) 324 | divErr(ex); 325 | n %= unBox(y); 326 | } 327 | return box(n); 328 | } 329 | 330 | // (>> 'num 'num) -> num 331 | any doShift(any ex) { 332 | any x, y; 333 | long n, m; 334 | 335 | x = cdr(ex), n = evNum(ex,x); 336 | x = cdr(x); 337 | if (isNil(y = EVAL(car(x)))) 338 | return Nil; 339 | NeedNum(ex,y); 340 | if ((m = unBox(y)) >= 0) 341 | m = n >= 0? m >> n : m << -n; 342 | else 343 | m = -(n >= 0? -m >> n : -m << -n); 344 | return box(m); 345 | } 346 | 347 | // (lt0 'any) -> num | NIL 348 | any doLt0(any x) { 349 | x = cdr(x); 350 | return isNum(x = EVAL(car(x))) && num(x)<0? x : Nil; 351 | } 352 | 353 | // (le0 'any) -> num | NIL 354 | any doLe0(any x) { 355 | x = cdr(x); 356 | return isNum(x = EVAL(car(x))) && num(x)<=num(Zero)? x : Nil; 357 | } 358 | 359 | // (ge0 'any) -> num | NIL 360 | any doGe0(any x) { 361 | x = cdr(x); 362 | return isNum(x = EVAL(car(x))) && num(x)>=0? x : Nil; 363 | } 364 | 365 | // (gt0 'any) -> num | NIL 366 | any doGt0(any x) { 367 | x = cdr(x); 368 | return isNum(x = EVAL(car(x))) && num(x)>num(Zero)? x : Nil; 369 | } 370 | 371 | // (abs 'num) -> num 372 | any doAbs(any ex) { 373 | any x; 374 | 375 | x = cdr(ex); 376 | if (isNil(x = EVAL(car(x)))) 377 | return Nil; 378 | NeedNum(ex,x); 379 | return num(x)<0? box(-unBox(x)) : x; 380 | } 381 | 382 | // (bit? 'num ..) -> num | NIL 383 | any doBitQ(any ex) { 384 | any x, y, z; 385 | 386 | x = cdr(ex), y = EVAL(car(x)); 387 | NeedNum(ex,y); 388 | if (num(y) < 0) 389 | y = box(-unBox(y)); 390 | while (isCell(x = cdr(x))) { 391 | if (isNil(z = EVAL(car(x)))) 392 | return Nil; 393 | NeedNum(ex,z); 394 | if ((unBox(y) & (num(z)<0? -unBox(z) : unBox(z))) != unBox(y)) 395 | return Nil; 396 | } 397 | return y; 398 | } 399 | 400 | // (& 'num ..) -> num 401 | any doBitAnd(any ex) { 402 | any x, y, z; 403 | 404 | x = cdr(ex); 405 | if (isNil(y = EVAL(car(x)))) 406 | return Nil; 407 | NeedNum(ex,y); 408 | if (num(y) < 0) 409 | y = box(-unBox(y)); 410 | while (isCell(x = cdr(x))) { 411 | if (isNil(z = EVAL(car(x)))) 412 | return Nil; 413 | NeedNum(ex,z); 414 | y = box(unBox(y) & (num(z)<0? -unBox(z) : unBox(z))); 415 | } 416 | return y; 417 | } 418 | 419 | // (| 'num ..) -> num 420 | any doBitOr(any ex) { 421 | any x, y, z; 422 | 423 | x = cdr(ex); 424 | if (isNil(y = EVAL(car(x)))) 425 | return Nil; 426 | NeedNum(ex,y); 427 | if (num(y) < 0) 428 | y = box(-unBox(y)); 429 | while (isCell(x = cdr(x))) { 430 | if (isNil(z = EVAL(car(x)))) 431 | return Nil; 432 | NeedNum(ex,z); 433 | y = box(unBox(y) | (num(z)<0? -unBox(z) : unBox(z))); 434 | } 435 | return y; 436 | } 437 | 438 | // (x| 'num ..) -> num 439 | any doBitXor(any ex) { 440 | any x, y, z; 441 | 442 | x = cdr(ex); 443 | if (isNil(y = EVAL(car(x)))) 444 | return Nil; 445 | NeedNum(ex,y); 446 | if (num(y) < 0) 447 | y = box(-unBox(y)); 448 | while (isCell(x = cdr(x))) { 449 | if (isNil(z = EVAL(car(x)))) 450 | return Nil; 451 | NeedNum(ex,z); 452 | y = box(unBox(y) ^ (num(z)<0? -unBox(z) : unBox(z))); 453 | } 454 | return y; 455 | } 456 | 457 | // (sqrt 'num ['flg|num]) -> num 458 | any doSqrt(any ex) { 459 | any x; 460 | long m, n, r; 461 | 462 | x = cdr(ex); 463 | if (isNil(x = EVAL(car(x)))) 464 | return Nil; 465 | NeedNum(ex,x); 466 | if ((n = unBox(x)) < 0) 467 | argError(ex, x); 468 | x = cddr(ex); 469 | if (isNum(x = EVAL(car(x)))) 470 | n *= unBox(x); 471 | m = 1L << BITS-4; 472 | r = 0; 473 | do { 474 | if ((r += m) > n) 475 | r -= m; 476 | else 477 | n -= r, r += m; 478 | r >>= 1; 479 | } while (m >>= 2); 480 | if (!isNil(x) && n > r) 481 | ++r; 482 | return box(r); 483 | } 484 | 485 | static uint64_t Seed; 486 | #define hi(t) (word)((t) >> 32) 487 | 488 | // (seed 'num) -> num 489 | any doSeed(any ex) { 490 | return box(hi(Seed = evNum(ex,cdr(ex)) * 6364136223846793005LL)); 491 | } 492 | 493 | // (rand ['num1 'num2] | ['T]) -> num | flg 494 | any doRand(any ex) { 495 | any x; 496 | long n, m; 497 | 498 | x = cdr(ex); 499 | Seed = Seed * 6364136223846793005LL + 1; 500 | if (isNil(x = EVAL(car(x)))) 501 | return box(hi(Seed)); 502 | if (x == T) 503 | return hi(Seed) & 1 ? T : Nil; 504 | n = xNum(ex,x); 505 | if (m = evNum(ex,cddr(ex)) + 1 - n) 506 | n += hi(Seed) % m; 507 | return box(n); 508 | } 509 | -------------------------------------------------------------------------------- /src/pico.h: -------------------------------------------------------------------------------- 1 | /* 27oct14abu 2 | * (c) Software Lab. Alexander Burger 3 | */ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | #ifndef CELLS 15 | #define CELLS (1024*1024/sizeof(cell)) 16 | #endif 17 | 18 | #define WORD ((int)sizeof(long)) 19 | #define BITS (8*WORD) 20 | 21 | typedef unsigned long word; 22 | typedef unsigned char byte; 23 | typedef unsigned char *ptr; 24 | 25 | #undef bool 26 | typedef enum {NO,YES} bool; 27 | 28 | typedef struct cell { // PicoLisp primary data type 29 | struct cell *car; 30 | struct cell *cdr; 31 | } cell, *any; 32 | 33 | typedef any (*fun)(any); 34 | 35 | #include "sym.d" 36 | 37 | typedef struct heap { 38 | cell cells[CELLS]; 39 | struct heap *next; 40 | } heap; 41 | 42 | typedef struct bindFrame { 43 | struct bindFrame *link; 44 | int i, cnt; 45 | struct {any sym; any val;} bnd[1]; 46 | } bindFrame; 47 | 48 | typedef struct inFrame { 49 | struct inFrame *link; 50 | void (*get)(void); 51 | FILE *fp; 52 | int next; 53 | } inFrame; 54 | 55 | typedef struct outFrame { 56 | struct outFrame *link; 57 | void (*put)(int); 58 | FILE *fp; 59 | } outFrame; 60 | 61 | typedef struct parseFrame { 62 | int i; 63 | word w; 64 | any sym, nm; 65 | } parseFrame; 66 | 67 | typedef struct stkEnv { 68 | cell *stack, *arg; 69 | bindFrame *bind; 70 | int next; 71 | any key, cls, *make, *yoke; 72 | inFrame *inFrames; 73 | outFrame *outFrames; 74 | parseFrame *parser; 75 | void (*get)(void); 76 | void (*put)(int); 77 | bool brk; 78 | } stkEnv; 79 | 80 | typedef struct catchFrame { 81 | struct catchFrame *link; 82 | any tag, fin; 83 | stkEnv env; 84 | jmp_buf rst; 85 | } catchFrame; 86 | 87 | /*** Macros ***/ 88 | #define Free(p) ((p)->car=Avail, Avail=(p)) 89 | 90 | /* Number access */ 91 | #define num(x) ((long)(x)) 92 | #define txt(n) ((any)(num(n)<<1|1)) 93 | #define box(n) ((any)(num(n)<<2|2)) 94 | #define unBox(n) (num(n)>>2) 95 | #define Zero ((any)2) 96 | #define One ((any)6) 97 | 98 | /* Symbol access */ 99 | #define symPtr(x) ((any)&(x)->cdr) 100 | #define val(x) ((x)->car) 101 | #define tail(x) (((x)-1)->cdr) 102 | 103 | /* Cell access */ 104 | #define car(x) ((x)->car) 105 | #define cdr(x) ((x)->cdr) 106 | #define caar(x) (car(car(x))) 107 | #define cadr(x) (car(cdr(x))) 108 | #define cdar(x) (cdr(car(x))) 109 | #define cddr(x) (cdr(cdr(x))) 110 | #define caaar(x) (car(car(car(x)))) 111 | #define caadr(x) (car(car(cdr(x)))) 112 | #define cadar(x) (car(cdr(car(x)))) 113 | #define caddr(x) (car(cdr(cdr(x)))) 114 | #define cdaar(x) (cdr(car(car(x)))) 115 | #define cdadr(x) (cdr(car(cdr(x)))) 116 | #define cddar(x) (cdr(cdr(car(x)))) 117 | #define cdddr(x) (cdr(cdr(cdr(x)))) 118 | #define cadddr(x) (car(cdr(cdr(cdr(x))))) 119 | #define cddddr(x) (cdr(cdr(cdr(cdr(x))))) 120 | 121 | #define data(c) ((c).car) 122 | #define Save(c) ((c).cdr=Env.stack, Env.stack=&(c)) 123 | #define drop(c) (Env.stack=(c).cdr) 124 | #define Push(c,x) (data(c)=(x), Save(c)) 125 | #define Pop(c) (drop(c), data(c)) 126 | 127 | #define Bind(s,f) ((f).i=0, (f).cnt=1, (f).bnd[0].sym=(s), (f).bnd[0].val=val(s), (f).link=Env.bind, Env.bind=&(f)) 128 | #define Unbind(f) (val((f).bnd[0].sym)=(f).bnd[0].val, Env.bind=(f).link) 129 | 130 | /* Predicates */ 131 | #define isNil(x) ((x)==Nil) 132 | #define isTxt(x) (num(x)&1) 133 | #define isNum(x) (num(x)&2) 134 | #define isSym(x) (num(x)&WORD) 135 | #define isSymb(x) ((num(x)&(WORD+2))==WORD) 136 | #define isCell(x) (!(num(x)&(2*WORD-1))) 137 | 138 | /* Evaluation */ 139 | #define EVAL(x) (isNum(x)? x : isSym(x)? val(x) : evList(x)) 140 | #define evSubr(f,x) (*(fun)(num(f) & ~2))(x) 141 | 142 | /* Error checking */ 143 | #define NeedNum(ex,x) if (!isNum(x)) numError(ex,x) 144 | #define NeedSym(ex,x) if (!isSym(x)) symError(ex,x) 145 | #define NeedSymb(ex,x) if (!isSymb(x)) symError(ex,x) 146 | #define NeedPair(ex,x) if (!isCell(x)) pairError(ex,x) 147 | #define NeedAtom(ex,x) if (isCell(x)) atomError(ex,x) 148 | #define NeedLst(ex,x) if (!isCell(x) && !isNil(x)) lstError(ex,x) 149 | #define NeedVar(ex,x) if (isNum(x)) varError(ex,x) 150 | #define CheckVar(ex,x) if ((x)>(any)Rom && (x)<=Quote) protError(ex,x) 151 | 152 | /* Globals */ 153 | extern int Chr, Trace; 154 | extern char **AV, *AV0, *Home; 155 | extern heap *Heaps; 156 | extern cell *Avail; 157 | extern stkEnv Env; 158 | extern catchFrame *CatchPtr; 159 | extern FILE *InFile, *OutFile; 160 | extern any TheKey, TheCls, Thrown; 161 | extern any Intern[2], Transient[2]; 162 | extern any ApplyArgs, ApplyBody; 163 | extern any const Rom[]; 164 | extern any Ram[]; 165 | 166 | /* Prototypes */ 167 | void *alloc(void*,size_t); 168 | any apply(any,any,bool,int,cell*); 169 | void argError(any,any) __attribute__ ((noreturn)); 170 | void atomError(any,any) __attribute__ ((noreturn)); 171 | void begString(void); 172 | void brkLoad(any); 173 | int bufNum(char[BITS/2],long); 174 | int bufSize(any); 175 | void bufString(any,char*); 176 | void bye(int) __attribute__ ((noreturn)); 177 | void pairError(any,any) __attribute__ ((noreturn)); 178 | any circ(any); 179 | long compare(any,any); 180 | any cons(any,any); 181 | any consName(word,any); 182 | any consSym(any,word); 183 | void newline(void); 184 | any endString(void); 185 | bool equal(any,any); 186 | void err(any,any,char*,...) __attribute__ ((noreturn)); 187 | any evExpr(any,any); 188 | any evList(any); 189 | long evNum(any,any); 190 | any evSym(any); 191 | void execError(char*) __attribute__ ((noreturn)); 192 | int firstByte(any); 193 | any get(any,any); 194 | int getByte(int*,word*,any*); 195 | int getByte1(int*,word*,any*); 196 | void getStdin(void); 197 | void giveup(char*) __attribute__ ((noreturn)); 198 | void heapAlloc(void); 199 | any intern(any,any[2]); 200 | bool isBlank(any); 201 | any isIntern(any,any[2]); 202 | void lstError(any,any) __attribute__ ((noreturn)); 203 | any load(any,int,any); 204 | any loadAll(any); 205 | any method(any); 206 | any mkChar(int); 207 | any mkChar2(int,int); 208 | any mkSym(byte*); 209 | any mkStr(char*); 210 | any mkTxt(int); 211 | any name(any); 212 | int numBytes(any); 213 | void numError(any,any) __attribute__ ((noreturn)); 214 | any numToSym(any,int,int,int); 215 | void outName(any); 216 | void outNum(long); 217 | void outString(char*); 218 | void pack(any,int*,word*,any*,cell*); 219 | int pathSize(any); 220 | void pathString(any,char*); 221 | void popInFiles(void); 222 | void popOutFiles(void); 223 | any popSym(int,word,any,cell*); 224 | void prin(any); 225 | void print(any); 226 | void protError(any,any) __attribute__ ((noreturn)); 227 | void pushInFiles(inFrame*); 228 | void pushOutFiles(outFrame*); 229 | void put(any,any,any); 230 | void putByte(int,int*,word*,any*,cell*); 231 | void putByte0(int*,word*,any*); 232 | void putByte1(int,int*,word*,any*); 233 | void putStdout(int); 234 | void rdOpen(any,any,inFrame*); 235 | any read1(int); 236 | int secondByte(any); 237 | void space(void); 238 | int symBytes(any); 239 | void symError(any,any) __attribute__ ((noreturn)); 240 | any symToNum(any,int,int,int); 241 | void undefined(any,any); 242 | void unintern(any,any[2]); 243 | void unwind (catchFrame*); 244 | void varError(any,any) __attribute__ ((noreturn)); 245 | void wrOpen(any,any,outFrame*); 246 | long xNum(any,any); 247 | any xSym(any); 248 | 249 | /* List element access */ 250 | static inline any nCdr(int n, any x) { 251 | while (--n >= 0) 252 | x = cdr(x); 253 | return x; 254 | } 255 | 256 | static inline any nth(int n, any x) { 257 | if (--n < 0) 258 | return Nil; 259 | return nCdr(n,x); 260 | } 261 | 262 | static inline any getn(any x, any y) { 263 | if (isNum(x)) { 264 | long n = unBox(x); 265 | 266 | if (n < 0) { 267 | while (++n) 268 | y = cdr(y); 269 | return cdr(y); 270 | } 271 | if (n == 0) 272 | return Nil; 273 | while (--n) 274 | y = cdr(y); 275 | return car(y); 276 | } 277 | do 278 | if (isCell(car(y)) && x == caar(y)) 279 | return cdar(y); 280 | while (isCell(y = cdr(y))); 281 | return Nil; 282 | } 283 | 284 | /* List length calculation */ 285 | static inline int length(any x) { 286 | int n; 287 | 288 | for (n = 0; isCell(x); x = cdr(x)) 289 | ++n; 290 | return n; 291 | } 292 | 293 | /* Membership */ 294 | static inline any member(any x, any y) { 295 | any z = y; 296 | 297 | while (isCell(y)) { 298 | if (equal(x, car(y))) 299 | return y; 300 | if (z == (y = cdr(y))) 301 | return NULL; 302 | } 303 | return isNil(y) || !equal(x,y)? NULL : y; 304 | } 305 | 306 | static inline any memq(any x, any y) { 307 | any z = y; 308 | 309 | while (isCell(y)) { 310 | if (x == car(y)) 311 | return y; 312 | if (z == (y = cdr(y))) 313 | return NULL; 314 | } 315 | return isNil(y) || x != y? NULL : y; 316 | } 317 | 318 | static inline int indx(any x, any y) { 319 | int n = 1; 320 | any z = y; 321 | 322 | while (isCell(y)) { 323 | if (equal(x, car(y))) 324 | return n; 325 | ++n; 326 | if (z == (y = cdr(y))) 327 | return 0; 328 | } 329 | return 0; 330 | } 331 | 332 | /* List interpreter */ 333 | static inline any prog(any x) { 334 | any y; 335 | 336 | do 337 | y = EVAL(car(x)); 338 | while (isCell(x = cdr(x))); 339 | return y; 340 | } 341 | 342 | static inline any run(any x) { 343 | any y; 344 | cell at; 345 | 346 | Push(at,val(At)); 347 | do 348 | y = EVAL(car(x)); 349 | while (isCell(x = cdr(x))); 350 | val(At) = Pop(at); 351 | return y; 352 | } 353 | -------------------------------------------------------------------------------- /src/pilog.s: -------------------------------------------------------------------------------- 1 | # 15jul15abu 2 | # (c) Software Lab. Alexander Burger 3 | 4 | # *Rule 5 | 6 | be (CL 7 | (clause CL) ) 8 | 9 | clause ((CL) 10 | (with (car CL) 11 | (if (== *Rule This) 12 | (queue (:: T) (cdr CL)) 13 | (=: T (cons (cdr CL))) 14 | (setq *Rule This) ) 15 | This ) ) 16 | 17 | repeat (() 18 | (conc (get *Rule T) (get *Rule T)) ) 19 | ,((NIL .) . T) 20 | 21 | asserta ((CL) 22 | (push (prop CL 1 T) (cdr CL)) ) 23 | 24 | assertz ((CL) 25 | (queue (prop CL 1 T) (cdr CL)) ) 26 | 27 | retract ((X) 28 | (if (sym? X) 29 | (put X T) 30 | (put (car X) T 31 | (delete (cdr X) (get (car X) T)) ) ) ) 32 | 33 | rules (@ 34 | (while (args) 35 | (let S (next) 36 | (for ((N . L) (get S T) L) 37 | (prin N " (be ") 38 | (print S) 39 | (for X (pop 'L) 40 | (space) 41 | (print X) ) 42 | (prinl ")") 43 | (T (== L (get S T)) 44 | (println '(repeat)) ) ) 45 | S ) ) ) 46 | 47 | ### Pilog Interpreter ### 48 | goal (("CL" . @) 49 | (let "Env" '(T) 50 | (while (args) 51 | (push '"Env" 52 | (cons (cons 0 (next)) 1 (next)) ) ) 53 | (while (and "CL" (pat? (car "CL"))) 54 | (push '"Env" 55 | (cons 56 | (cons 0 (pop '"CL")) 57 | (cons 1 (eval (pop '"CL"))) ) ) ) 58 | (cons 59 | (cons 60 | (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) 61 | 62 | fail (() 63 | (goal '((NIL))) ) 64 | 65 | pilog (("CL" . "Prg") 66 | (for ("Q" (goal "CL") (prove "Q")) 67 | (bind @ (run "Prg")) ) ) 68 | 69 | solve (("CL" . "Prg") 70 | (make 71 | (if "Prg" 72 | (for ("Q" (goal "CL") (prove "Q")) 73 | (link (bind @ (run "Prg"))) ) 74 | (for ("Q" (goal "CL") (prove "Q")) 75 | (link @) ) ) ) ) 76 | 77 | query (("Q" "Dbg") 78 | (use "R" 79 | (loop 80 | (NIL (prove "Q" "Dbg")) 81 | (T (=T (setq "R" @)) T) 82 | (for X "R" 83 | (space) 84 | (print (car X)) 85 | (print '=) 86 | (print (cdr X)) 87 | (flush) ) 88 | (T (line)) ) ) ) 89 | 90 | ? ("CL" 91 | (let "L" 92 | (make 93 | (while (nor (pat? (car "CL")) (lst? (car "CL"))) 94 | (link (pop '"CL")) ) ) 95 | (query (goal "CL") "L") ) ) 96 | 97 | ### Basic Rules ### 98 | true NIL 99 | ,((NIL) . T) 100 | 101 | call NIL 102 | ,(((@P (2 (cons (-> @P))))) . T) 103 | 104 | _or NIL 105 | ,((((@C) (3 (pop (-> @C)))) ((@C) (^ @ (not (val (-> @C)))) T (fail)) .) . T) 106 | 107 | equal NIL 108 | ,((((@X @X))) . T) 109 | 110 | different NIL 111 | ,((((@X @X) T (fail)) ((@ @))) . T) 112 | 113 | permute NIL 114 | ,(((((@X) (@X))) ((@L (@X . @Y)) (delete @X @L @D) (permute @D @Y))) . T) 115 | 116 | uniq NIL 117 | ,((((@B @X) (^ @ (not (idx (-> @B) (-> @X) T))))) . T) 118 | 119 | asserta NIL 120 | ,((((@C) (^ @ (asserta (-> @C))))) . T) 121 | 122 | assertz NIL 123 | ,((((@C) (^ @ (assertz (-> @C))))) . T) 124 | 125 | retract NIL 126 | ,((((@C) (2 (cons (-> @C))) (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))))) . T) 127 | 128 | clause NIL 129 | ,(((("@H" "@B") (^ "@A" (get (-> "@H") T)) (member "@B" "@A"))) . T) 130 | 131 | _for NIL 132 | ,((((@N @I @End @Step) (^ @ (if (>= (-> @End) (val (-> @I))) (> (inc (-> @I) (-> @Step)) (-> @End)) (> (-> @End) (dec (-> @I) (-> @Step))))) T (fail)) ((@N @I @End @Step) (^ @N (val (-> @I)))) .) . T) 133 | 134 | lst NIL 135 | ,((((@V . @L) (^ @Lst (box (apply get (-> @L)))) (_lst @V @Lst))) . T) 136 | 137 | _lst NIL 138 | ,((((@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) ((@Val @Lst) (^ @Val (pop (-> @Lst)))) .) . T) 139 | 140 | _map NIL 141 | ,((((@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) ((@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst))))) .) . T) 142 | 143 | # vi:et:ts=3:sw=3 144 | --------------------------------------------------------------------------------