├── .gitignore ├── Makefile ├── README.md ├── a2lisp.c └── turtles.asm /.gitignore: -------------------------------------------------------------------------------- 1 | turtles.o65 2 | turtles_expanded.asm 3 | transport 4 | a2lisp 5 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | clean: 2 | -@rm turtles.o65 2> /dev/null 3 | # -@rm a2lisp 4 | 5 | # Expand macros with CPP, then remove all newlines and CPP junk 6 | compile: 7 | # @gcc -Wall -std=gnu99 a2lisp.c -o a2lisp 8 | @cl65 -tapple2 -C apple2-system.cfg a2lisp.c -o a2lisp 9 | # @xa turtles.asm -M -o turtles.o65 10 | 11 | send: compile 12 | @./transport a2lisp | sox -b 8 -r 44100 -L -c 1 -t raw -e unsigned-integer - -d 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Building and running 2 | 3 | The first thing you need to do is build and compile [apple2e-audio-transport](https://github.com/hausdorff/apple2e-audio-transport) (itself largely derived from a core part of [ADTPro](http://adtpro.cvs.sourceforge.net/)), which will allow you to transport the interpreter over the wire to the Apple IIe. It's a matter of running `make compile` and dumping the binary (which is called `transport` at this point) into the directory of this project. 4 | 5 | Next you want to make sure to grab all the other (public, widely-available) source dependencies below. 6 | 7 | Now the interesting part. 8 | 9 | > **TEMPORARY NOTE:** We have developed a full prototype in C. The file is `a2lisp.c`, and you can compile and send this across the wire. The eventual target is 6502 assembly, which we are in the process of porting now. 10 | 11 | [Here](http://www.youtube.com/watch?v=tey9sFqICSk) is a YouTube demo (GitHub doesn't let you embed videos in readmes). 12 | 13 | Hook up your Apple II e to the audio jack. Run `make send` on your home computer. You should see something like the following: 14 | 15 | ``` 16 | $ make send 17 | Length: 351 18 | Load at: 0800..095e 19 | Press enter when ready... 20 | -: (raw) 21 | 22 | Encoding: Signed PCM 23 | Channels: 1 @ 32-bit 24 | Samplerate: 44100Hz 25 | Replaygain: off 26 | Duration: unknown 27 | 28 | In:0.00% 00:00:00.00 [00:00:00.00] Out:0 [ | ] Clip:0 29 | ``` 30 | 31 | This program is waiting for you to press return to send the message. Don't press return yet. 32 | 33 | The second line says `Load at: $x..$y`, where `$x` and `$y` are hex addresses. Now go to your Apple IIe and open the monitor program. Usually this is `call -151`, but it might depend on your system. (We're on ProDOS.) The Monitor prompt like this: 34 | 35 | `*` 36 | 37 | Type `$x..$yR` into your Apple IIe's Monitor prompt. This will tell the Apple IIe to load from the audio port. 38 | 39 | It will wait until it receives an answer. 40 | 41 | Now press enter on your home machine to transmit the data. 42 | 43 | You might have to run `make send` and press enter again---I'm not sure why it does this, but transmitting the package again should work. 44 | 45 | This should drop you into the prompt. 46 | 47 | # Examples 48 | Below we provide some examples of what you can do with the current prototype. 49 | 50 | ## Atoms and primitives 51 | Numbers evaluate to themselves: 52 | 53 | > 42 54 | 42 55 | 56 | Basic arithmetic is provided by the built-in primitives `PLUS`, `MINUS`, 57 | `MUL` and `DIV`: 58 | 59 | > (PLUS 5 5) 60 | 10 61 | > (MUL 11 10) 62 | 110 63 | > (PLUS 5 (MUL 10 10)) 64 | 105 65 | 66 | Lists are constructed using the `CONS` primitive. To extract the first element 67 | of a list, apply `CAR` to it. To extract the remainder (tail) of the list, 68 | apply `CDR`. The emtpy list is known as `'()` or `NIL`. 69 | 70 | > (CONS 1 NIL) 71 | (1) 72 | > (CAR (CONS 1 (CONS 2 NIL))) 73 | 1 74 | > (CDR (CONS 1 (CONS 2 NIL))) 75 | (2) 76 | 77 | ## Quotation 78 | Any datum can be "quoted", meaning it is taken literally and returned 79 | unevaluated: 80 | 81 | > (QUOTE 1) 82 | 1 83 | > (QUOTE (1 2 3)) 84 | (1 2 3) 85 | 86 | The shorthand `'` can be used for the same effect: 87 | 88 | > '(1 2 3) 89 | (1 2 3) 90 | 91 | ## Conditionals 92 | The `IF` form provides conditional tests. Everything that is not `NIL` 93 | is true: 94 | 95 | > (IF 'FOO 'YES 'NO) 96 | YES 97 | > (IF CONS 'YES 'NO) 98 | YES 99 | > (IF '() 'YES 'NO) 100 | NO 101 | 102 | ## Lambdas 103 | The `LAMBDA` form can be used to construct an anonymous function. 104 | Turtles is lexically scoped, meaning that names bind to their lexically 105 | "closest" definition: 106 | 107 | > (LAMBDA () 'FOO) 108 | # 109 | > ((LAMBDA (X) (PLUS X X)) 10) 110 | 20 111 | 112 | We have full support for closures, meaning that variables in a surrounding 113 | scope are "captured" by the `LAMBDA` form. For example, in this case `X` 114 | is captured by the inner lambda. 115 | 116 | > (((LAMBDA (X) (LAMBDA (Y) (PLUS X Y))) 5) 10) 117 | 15 118 | 119 | ## Global definitions 120 | Global names can be bound to values using the `DEFINE` form: 121 | 122 | > (DEFINE X 42) 123 | > X 124 | 42 125 | 126 | Global functions are easily defined by combining `DEFINE` with `LAMBDA`: 127 | 128 | > (DEFINE F (LAMBDA (X Y) (PLUS X Y))) 129 | > (F 2 3) 130 | 5 131 | 132 | ## Basic recursion 133 | We can easily define a recursive function to count the elements of a list: 134 | 135 | > (DEFINE LENGTH (LAMBDA (L) 136 | (IF L 137 | (PLUS 1 (LENGTH (CDR L))) 138 | 0))) 139 | 140 | ## Higher order programming 141 | The forms we have explored so far are sufficient to define some common 142 | higher order programming tools, such as `MAP`: 143 | 144 | > (DEFINE MAP (LAMBDA (F L) 145 | (IF L 146 | (CONS (F (CAR L)) (MAP F (CDR L))) 147 | '()))) 148 | 149 | We can use this in conjunction with `LAMBDA` to square the elements of a list: 150 | 151 | > (MAP (LAMBDA (X) (MUL X X)) '(1 2 3) 152 | (1 4 9) 153 | 154 | # Dependencies 155 | 156 | * [apple2e-audio-transport](https://github.com/hausdorff/apple2e-audio-transport), a small library written specifically for this project. Sends the program over the audio jack to the Apple IIe. 157 | * [sox](http://sox.sourceforge.net/), which we use to emit sound to the Apple IIe. 158 | * [cpp](http://gcc.gnu.org/onlinedocs/cpp/), the C preprocessor; we write macros to make programming in the 6502 instruction set slightly easier. 159 | * [xa](http://www.floodgap.com/retrotech/xa/)(aka xa65), assembler for the 6502 instruction set. 160 | 161 | # LICENSE 162 | 163 | Distributed under MIT, which basically means that if you should use this code for anything, you just have to keep a note saying we wrote the code. That said, God help you should you actually decide to use this code. 164 | 165 | 166 | ## MIT License 167 | 168 | Copyright (C) 2013 Martin Törnwall (@mtornwall), Alex Clemmer (@hausdorff) 169 | 170 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 171 | 172 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 173 | 174 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 175 | -------------------------------------------------------------------------------- /a2lisp.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | #define LISP_NIL ((Value*)1) 10 | #define LISP_NILP(v) ((Value*)v == LISP_NIL) 11 | 12 | #define CAR(v) ((v)->pair.car) 13 | #define CDR(v) ((v)->pair.cdr) 14 | #define CAAR(v) ((v)->pair.car->pair.car) 15 | #define CADR(v) ((v)->pair.cdr->pair.car) 16 | #define CDAR(v) ((v)->pair.car->pair.cdr) 17 | #define CDDR(v) ((v)->pair.cdr->pair.cdr) 18 | #define CAAAR(v) ((v)->pair.car->pair.car->pair.car) 19 | #define CAADR(v) ((v)->pair.cdr->pair.car->pair.car) 20 | #define CADAR(v) ((v)->pair.car->pair.cdr->pair.car) 21 | #define CADDR(v) ((v)->pair.cdr->pair.cdr->pair.car) 22 | #define CDAAR(v) ((v)->pair.car->pair.car->pair.cdr) 23 | #define CDADR(v) ((v)->pair.cdr->pair.car->pair.cdr) 24 | #define CDDAR(v) ((v)->pair.car->pair.cdr->pair.cdr) 25 | #define CDDDR(v) ((v)->pair.cdr->pair.cdr->pair.cdr) 26 | 27 | typedef struct value { 28 | uint8_t type; 29 | union { 30 | int int_; 31 | char sym[1]; 32 | struct value* (*fn)(struct value*); 33 | struct { 34 | struct value *args; 35 | struct value *body; 36 | struct value *env; 37 | } lambda; 38 | struct { 39 | struct value *car; 40 | struct value *cdr; 41 | } pair; 42 | }; 43 | } Value; 44 | 45 | typedef enum type { 46 | T_INT, 47 | T_SYM, 48 | T_PAIR, 49 | T_NATIVE, 50 | T_LAMBDA 51 | } Type; 52 | 53 | char *heap; // grows up 54 | char *heap_end; 55 | 56 | #define SYMBOL_TABLE_SIZE 255 57 | Value *syms[SYMBOL_TABLE_SIZE]; 58 | 59 | // Symbols for primitives. Initialized in init(). 60 | Value *quote_sym = NULL, 61 | *lambda_sym = NULL, 62 | *define_sym = NULL, 63 | *if_sym = NULL; 64 | 65 | // Global environment. 66 | Value *global_env; 67 | 68 | // Jump buffer for escaping a failing eval back to the top level. 69 | jmp_buf toplevel_escape; 70 | 71 | void error(const char *what) 72 | { 73 | printf("*** %s\n", what); 74 | longjmp(toplevel_escape, 0); 75 | } 76 | 77 | Value *mksym(const char *); 78 | Value *mkpair(Value *, Value *); 79 | void init() 80 | { 81 | int i; 82 | size_t s = 16384; 83 | 84 | heap = malloc(s); 85 | heap_end = heap + s; 86 | 87 | for (i = 0; i < SYMBOL_TABLE_SIZE; i++) { 88 | syms[i] = LISP_NIL; 89 | } 90 | 91 | quote_sym = mksym("QUOTE"); 92 | lambda_sym = mksym("LAMBDA"); 93 | define_sym = mksym("DEFINE"); 94 | if_sym = mksym("IF"); 95 | 96 | // Set up the global environment as a single, "empty" binding. 97 | // This is done so that we can "splice" global definitions into 98 | // the global environment rather than "extending" the global 99 | // environment in the regular fashion. Otherwise, global mutual 100 | // recursion would not be possible. 101 | global_env = mkpair(mkpair(LISP_NIL, LISP_NIL), LISP_NIL); 102 | } 103 | 104 | void gc() 105 | { 106 | printf("Running gc\n"); 107 | } 108 | 109 | void maybe_gc(size_t nalloc) 110 | { 111 | if (heap + nalloc >= heap_end) { 112 | gc(); 113 | } 114 | } 115 | 116 | Value *mkpair(Value *car, Value *cdr) 117 | { 118 | Value *p; 119 | const size_t nalloc = sizeof(Value); 120 | 121 | maybe_gc(nalloc); 122 | p = (Value *) heap; 123 | p->type = T_PAIR; 124 | p->pair.car = car; 125 | p->pair.cdr = cdr; 126 | heap += nalloc; 127 | return p; 128 | } 129 | 130 | Value *mkint(int v) 131 | { 132 | Value *p; 133 | const size_t nalloc = sizeof(Value); 134 | 135 | maybe_gc(nalloc); 136 | p = (Value *) heap; 137 | p->type = T_INT; 138 | p->int_ = v; 139 | heap += nalloc; 140 | return p; 141 | } 142 | 143 | Value *mknative(Value* (*fn)(Value *)) 144 | { 145 | Value *p; 146 | const size_t nalloc = sizeof(Value); 147 | 148 | maybe_gc(nalloc); 149 | p = (Value *) heap; 150 | p->type = T_NATIVE; 151 | p->fn = fn; 152 | heap += nalloc; 153 | return p; 154 | } 155 | 156 | Value *mklambda(Value *args, Value *body, Value *env) 157 | { 158 | Value *p; 159 | const size_t nalloc = sizeof(Value); 160 | 161 | maybe_gc(nalloc); 162 | p = (Value *) heap; 163 | p->type = T_LAMBDA; 164 | p->lambda.args = args; 165 | p->lambda.body = body; 166 | p->lambda.env = env; 167 | heap += nalloc; 168 | return p; 169 | } 170 | 171 | uint8_t gethash(const char *); 172 | Value *mksym(const char *sym) 173 | { 174 | uint8_t hash = gethash(sym); 175 | const size_t length = strlen(sym); 176 | const size_t nalloc = sizeof(Value) + length + 1; 177 | Value *pair, *prim; 178 | 179 | pair = syms[hash]; 180 | for (; !LISP_NILP(pair); pair = CDR(pair)) { 181 | Value *prim = CAR(pair); 182 | if (strcasecmp(prim->sym, sym) == 0) { 183 | return prim; 184 | } 185 | } 186 | 187 | maybe_gc(nalloc); 188 | prim = (Value *) heap; 189 | prim->type = T_SYM; 190 | strcpy(prim->sym, sym); 191 | heap += nalloc; 192 | syms[hash] = mkpair(prim, syms[hash]); 193 | return prim; 194 | } 195 | 196 | uint8_t gethash(const char *sym) 197 | { 198 | uint8_t hash = 0; 199 | const size_t length = strlen(sym); 200 | size_t i; 201 | 202 | for (i = 0; i < length; i++) { 203 | hash ^= tolower(sym[i]); 204 | } 205 | // XXX: Alex says this blows. I think he's optimizing prematurely. 206 | return hash; 207 | } 208 | 209 | Type gettype(Value *ptr) 210 | { 211 | return ptr->type; 212 | } 213 | 214 | char peekchar() 215 | { 216 | char ch = getchar(); 217 | ungetc(ch, stdin); 218 | return ch; 219 | } 220 | 221 | Value *lreadsym() 222 | { 223 | char buf[32]; 224 | char *p = buf; 225 | char ch; 226 | while (isalpha((ch = getchar()))) { 227 | *p++ = ch; 228 | } 229 | ungetc(ch, stdin); 230 | *p = '\0'; 231 | return mksym(buf); 232 | } 233 | 234 | Value *lreadint() 235 | { 236 | int v = 0; 237 | char ch; 238 | while (isdigit((ch = getchar()))) { 239 | v = v*10 + (ch - '0'); 240 | } 241 | ungetc(ch, stdin); 242 | return mkint(v); 243 | } 244 | 245 | Value *lread(); 246 | Value *lreadlist() 247 | { 248 | Value *car, *cdr; 249 | 250 | if (peekchar() == ')') { 251 | getchar(); // eat ) 252 | return LISP_NIL; 253 | } 254 | car = lread(); 255 | cdr = lreadlist(); 256 | return mkpair(car, cdr); 257 | } 258 | 259 | Value *lread() 260 | { 261 | char ch; 262 | again: 263 | ch = getchar(); 264 | if (isspace(ch)) goto again; 265 | 266 | ungetc(ch, stdin); 267 | if (isalpha(ch)) return lreadsym(); 268 | else if (isdigit(ch)) return lreadint(); 269 | else if (ch == '(') { getchar(); return lreadlist(); } 270 | else if (ch == '\'') { 271 | getchar(); 272 | return mkpair(quote_sym, mkpair(lread(), LISP_NIL)); 273 | } else { 274 | getchar(); 275 | error("Unrecognized token."); 276 | exit(1); 277 | } 278 | } 279 | 280 | void lwriteint(Value *ptr) 281 | { 282 | printf("%d", ptr->int_); 283 | } 284 | 285 | void lwritesym(Value *ptr) 286 | { 287 | printf("%s", ptr->sym); 288 | } 289 | 290 | void lwritenative(Value *ptr) 291 | { 292 | printf("#"); 293 | } 294 | 295 | void lwritelambda(Value *ptr) 296 | { 297 | printf("#"); 298 | } 299 | 300 | void lwrite(Value *); 301 | void lwritepair(Value *pair) 302 | { 303 | printf("("); 304 | for (; !LISP_NILP(pair); pair = CDR(pair)) { 305 | lwrite(CAR(pair)); 306 | if (!LISP_NILP(CDR(pair))) { 307 | if (gettype(CDR(pair)) == T_PAIR) { 308 | printf(" "); 309 | } else { 310 | // Handle improper lists 311 | printf(" . "); 312 | lwrite(CDR(pair)); 313 | break; 314 | } 315 | } 316 | } 317 | printf(")"); 318 | } 319 | 320 | void lwrite(Value *ptr) 321 | { 322 | if (ptr == LISP_NIL) { 323 | printf("NIL"); 324 | return; 325 | } 326 | 327 | switch (gettype(ptr)) { 328 | case T_INT: lwriteint(ptr); break; 329 | case T_SYM: lwritesym(ptr); break; 330 | case T_NATIVE: lwritenative(ptr); break; 331 | case T_LAMBDA: lwritelambda(ptr); break; 332 | case T_PAIR: lwritepair(ptr); break; 333 | } 334 | } 335 | 336 | Value *eval(Value *, Value *); 337 | Value *mapeval(Value *list, Value *env) 338 | { 339 | if (list == LISP_NIL) 340 | return LISP_NIL; 341 | return mkpair(eval(CAR(list), env), mapeval(CDR(list), env)); 342 | } 343 | 344 | Value *bind(Value *name, Value *value, Value *env) 345 | { 346 | Value *binding = mkpair(name, value); 347 | return mkpair(binding, env); 348 | } 349 | 350 | Value *lookup(Value *name, Value *env) 351 | { 352 | assert(gettype(name) == T_SYM); 353 | for (; !LISP_NILP(env); env = CDR(env)) { 354 | // Pointer comparison is OK for interned symbols. 355 | Value *binding = CAR(env); 356 | if (CAR(binding) == name) 357 | return CDR(binding); 358 | } 359 | return NULL; 360 | } 361 | 362 | Value *apply(Value *proc, Value *args) 363 | { 364 | switch (gettype(proc)) { 365 | case T_NATIVE: 366 | return proc->fn(args); 367 | case T_LAMBDA: 368 | { 369 | Value *call_env = proc->lambda.env; 370 | Value *formal = proc->lambda.args; 371 | Value *actual = args; 372 | while (!LISP_NILP(formal) && !LISP_NILP(actual)) { 373 | call_env = bind(CAR(formal), CAR(actual), call_env); 374 | formal = CDR(formal); 375 | actual = CDR(actual); 376 | } 377 | 378 | // Argument count mismatch? 379 | if (formal != actual) { 380 | error("Argument count mismatch.\n"); 381 | exit(1); 382 | } 383 | 384 | return eval(proc->lambda.body, call_env); 385 | } break; 386 | default: 387 | error("Type is not callable."); 388 | exit(1); 389 | } 390 | } 391 | 392 | void defglobal(Value *, Value *); 393 | Value *eval_define(Value *form, Value *env) 394 | { 395 | Value *name = CADR(form); 396 | Value *value = eval(CADDR(form), env); 397 | defglobal(name, value); 398 | return name; 399 | } 400 | 401 | Value *eval_lambda(Value *form, Value *env) 402 | { 403 | Value *lambda_args = CADR(form); 404 | Value *lambda_body = CADDR(form); 405 | return mklambda(lambda_args, lambda_body, env); 406 | } 407 | 408 | Value *eval_if(Value *form, Value *env) 409 | { 410 | if (!LISP_NILP(eval(CADR(form), env))) { 411 | return eval(CADDR(form), env); 412 | } else { 413 | return eval(CAR(CDDDR(form)), env); 414 | } 415 | } 416 | 417 | Value *eval(Value *form, Value *env) 418 | { 419 | switch (gettype(form)) { 420 | case T_INT: return form; 421 | case T_SYM: 422 | { 423 | Value *value = lookup(form, env); 424 | if (value == NULL) { 425 | error("Undefined symbol."); 426 | exit(1); 427 | } 428 | return value; 429 | } break; 430 | case T_PAIR: 431 | { 432 | Value *verb = CAR(form); 433 | 434 | if (verb == quote_sym) { 435 | return CADR(form); 436 | } else if (verb == lambda_sym) { 437 | return eval_lambda(form, env); 438 | } else if (verb == if_sym) { 439 | return eval_if(form, env); 440 | } else if (verb == define_sym) { 441 | return eval_define(form, env); 442 | } else { 443 | return apply(eval(verb, env), mapeval(CDR(form), env)); 444 | } 445 | } break; 446 | default: 447 | error("I don't know how to evaluate that."); 448 | break; 449 | } 450 | } 451 | 452 | void defglobal(Value *name, Value *value) 453 | { 454 | global_env->pair.cdr = bind(name, value, global_env->pair.cdr); 455 | } 456 | 457 | void defnative(Value *name, Value* (*fn)(Value *)) 458 | { 459 | defglobal(name, mknative(fn)); 460 | } 461 | 462 | // List manipulation. 463 | Value *native_cons(Value *args) { return mkpair(CAR(args), CADR(args)); } 464 | Value *native_car(Value *args) { return CAAR(args); } 465 | Value *native_cdr(Value *args) { return CDAR(args); } 466 | 467 | // Arithmetic. 468 | #define ARITH(op) mkint(CAR(args)->int_ op CADR(args)->int_) 469 | Value *native_plus(Value *args) { return ARITH(+); } 470 | Value *native_minus(Value *args) { return ARITH(-); } 471 | Value *native_mul(Value *args) { return ARITH(*); } 472 | Value *native_div(Value *args) { return ARITH(/); } 473 | #undef ARITH 474 | 475 | // Miscellaneous. 476 | Value *native_eval(Value *args) { return eval(CAR(args), global_env); } 477 | 478 | int main() 479 | { 480 | Value *result; 481 | 482 | init(); 483 | // List manipulation. 484 | defnative(mksym("CONS"), native_cons); 485 | defnative(mksym("CAR"), native_car); 486 | defnative(mksym("CDR"), native_cdr); 487 | 488 | // Arithmetic. 489 | defnative(mksym("PLUS"), native_plus); 490 | defnative(mksym("MINUS"), native_minus); 491 | defnative(mksym("MUL"), native_mul); 492 | defnative(mksym("DIV"), native_div); 493 | 494 | // Miscellaneous. 495 | defnative(mksym("EVAL"), native_eval); 496 | defglobal(mksym("NIL"), LISP_NIL); 497 | 498 | while (!feof(stdin)) { 499 | setjmp(toplevel_escape); 500 | printf("> "); 501 | result = eval(lread(), global_env); 502 | printf("\n"); 503 | lwrite(result); 504 | printf("\n"); 505 | } 506 | 507 | return 0; 508 | } 509 | -------------------------------------------------------------------------------- /turtles.asm: -------------------------------------------------------------------------------- 1 | ;;; Apple //e Lisp 2 | ;;; Copyright (c) 2013, Alex Clemmer and Martin Törnwall 3 | ;;; 4 | ;;; This program is free software distributed under the terms of the 5 | ;;; MIT license. See the enclosed LICENSE file for more information. 6 | 7 | ;;; 8 | ;;; SOFTWARE STACK: 9 | ;;; 10 | ;;; The software stack starts high in memory (configurable) and grows downward. 11 | ;;; It should be used for pushing pointer-sized (16 bits) values only. 12 | ;;; The software stack is scanned conservatively when determining the GC 13 | ;;; root set, so anything on the stack that looks like a pointer is treated 14 | ;;; as such. 15 | ;;; 16 | ;;; HEAP: 17 | ;;; 18 | ;;; The heap stores LISP objects. It starts at a "low" address and grows 19 | ;;; upwards towards the top of the stack. Heap and stack overflows are 20 | ;;; trivially checked by comparing the two pointers. Unlike the stack, the 21 | ;;; heap is not automatically managed; as objects become unreachable, a 22 | ;;; garbage collector kicks in and cleans them up. 23 | ;;; 24 | ;;; Every object on the heap is tagged with a one-byte "type tag". 25 | ;;; Currently the following types are recognized: 26 | ;;; - Pairs (cons cells, to form lists) 27 | ;;; - Integers 28 | ;;; - Symbols (interned, to allow "eq?"-type comparisons) 29 | ;;; 30 | ;;; APPROXIMATE MEMORY MAP: 31 | ;;; 32 | ;;; +-------+ $FFFF 33 | ;;; | ROM | 34 | ;;; +-------+ 35 | ;;; | sstk | Software stack. Grows down towards the heap. 36 | ;;; +-------+ 37 | ;;; | | 38 | ;;; | heap | LISP heap. Grows up towards the software stack. 39 | ;;; | | 40 | ;;; +-------+ 41 | ;;; | LISP | 42 | ;;; | intrp | 43 | ;;; +-------+ 44 | ;;; | txt | Text-mode page 1. Used for text output. 45 | ;;; +-------+ 46 | ;;; | hwstk | Hardware stack (fixed at page $01) 47 | ;;; +-------+ 48 | ;;; | ZP | Zero-page used as scratchpad and pointer storage. 49 | ;;; +-------+ $0000 50 | ;;; 51 | ;;; CALLING CONVENTION: 52 | ;;; 53 | ;;; Procedure calls shall not clobber the X and Y registers. The A register is 54 | ;;; used for the return value and is thus not preserved across calls. It is 55 | ;;; always the callee's responsibility to preserve X and Y. The special 56 | ;;; PTR location on the ZP is used to return 16-bit results. 57 | ;;; 58 | ;;; Parameters are passed on the software stack in reverse order. 59 | ;;; The callee is responsible for popping arguments of the stack, 60 | ;;; meaning that SSP_before_call = SSP_after_call. 61 | 62 | ;; Heap object type codes. 63 | #define TYPE_PAIR #0 64 | #define TYPE_INTEGER #1 65 | #define TYPE_SYMBOL #2 66 | 67 | ;; Push/pop macros for the X and Y registers. 68 | ;; Could be mapped to PHX/PLX and PHY/PLY on the 65C02. 69 | #define PUSH_X TXA : PHA 70 | #define POP_X PLA : TAX 71 | #define PUSH_Y TYA : PHA 72 | #define POP_Y PLA : TAY 73 | 74 | SSP = $00 ;; Software stack pointer (two locations) 75 | HEAP = $02 ;; Heap pointer (two locations) 76 | PTR = $04 ;; 16-bit return "register" (two locations) 77 | 78 | * = $0800 79 | 80 | INIT: 81 | ;; Initialize software stack at $BFFE (I/O space starts at $C000) 82 | LDA #$FF : STA SSP ; SSP_low = $FE 83 | LDA #$BF : STA SSP+1 ; SSP_high = $BF 84 | ;; Initialize the heap pointer at 85 | LDA #CODE_END : STA HEAP+1 ; HEAP_high = end of code high 87 | ;; TODO Initialize symbol hash table. 88 | ;; TODO Set up global symbols (quote, lambda and define) 89 | ;; TODO Initialize the global environment. 90 | BRK 91 | 92 | ;; GC() -> NONE 93 | GC: 94 | RTS 95 | 96 | ;; MAYBE_GC(SIZE :: BYTE) -> NONE 97 | MAYBE_GC: 98 | RTS 99 | 100 | ;; MAKE_PAIR(CAR :: PTR, CDR :: PTR) -> PTR 101 | ;; Allocates a pair on the heap, returning a pointer to it in PTR. 102 | MAKE_PAIR: 103 | PUSH_Y 104 | ;; Do garbage collection prior to allocation as needed. 105 | LDA #5 : JSR S_PUSH_A 106 | JSR MAYBE_GC 107 | LDY #0 108 | LDA TYPE_PAIR : STA (HEAP),Y : INY 109 | ;; Store the CAR. 110 | JSR S_POP_PTR ; get CAR 111 | LDA PTR : STA (HEAP),Y : INY 112 | LDA PTR+1 : STA (HEAP),Y : INY 113 | ;; Store the CDR. 114 | JSR S_POP_PTR ; get CDR 115 | LDA PTR : STA (HEAP),Y : INY 116 | LDA PTR+1 : STA (HEAP),Y : INY 117 | ;; Increment the heap pointer. 118 | JSR S_PUSH_Y 119 | JSR HEAP_INC 120 | POP_Y 121 | RTS 122 | 123 | ;; MAKE_INTEGER(VALUE :: PTR) -> PTR 124 | ;; Allocates an integer on the heap, returning a pointer to it in PTR. 125 | MAKE_INTEGER: 126 | PUSH_Y 127 | JSR S_POP_PTR 128 | ;; Do garbage collection prior to allocation as needed. 129 | LDA #3 : JSR S_PUSH_A 130 | JSR MAYBE_GC 131 | LDY #0 132 | LDA TYPE_INTEGER : STA (HEAP),Y : INY ; Store type code. 133 | LDA PTR : STA (HEAP),Y : INY ; Store low byte. 134 | LDA PTR : STA (HEAP),Y : INY ; Store high byte. 135 | ;; Increment the heap pointer. 136 | JSR S_PUSH_Y 137 | JSR HEAP_INC 138 | POP_Y 139 | RTS 140 | 141 | ;; HEAP_INC(SIZE :: BYTE) -> PTR 142 | ;; Increment the heap pointer by the given size in bytes. 143 | ;; Returns the original heap pointer in PTR. 144 | HEAP_INC: 145 | ;; Get original ("current") heap pointer. 146 | LDA HEAP : STA PTR 147 | LDA HEAP+1 : STA PTR+1 148 | ;; Increment the heap pointer by the given size. 149 | JSR S_POP_A ; Pop size. 150 | CLC 151 | ADC HEAP 152 | STA HEAP 153 | BCC HEAP_INC_END ; Carried? 154 | INC HEAP+1 ; Yep; increment high byte. 155 | HEAP_INC_END: 156 | RTS 157 | 158 | ;; S_PUSH_X() -> NONE 159 | ;; Pushes the X register twice onto the stack as the software 160 | ;; stack is required to be aligned on a 16-bit boundary. 161 | S_PUSH_X: 162 | TXA 163 | JMP S_PUSH_A 164 | 165 | ;; S_PUSH_Y() -> NONE 166 | ;; Pushes the Y register twice onto the stack as the software 167 | ;; stack is required to be aligned on a 16-bit boundary. 168 | S_PUSH_Y: 169 | TYA 170 | JMP S_PUSH_A 171 | 172 | ;; S_PUSH_A() -> NONE 173 | ;; Pushes the A register twice onto the stack as the software 174 | ;; stack is required to be aligned on a 16-bit boundary. 175 | S_PUSH_A: 176 | PUSH_Y 177 | LDY #0 178 | STA (SSP),Y 179 | INY 180 | STA (SSP),Y 181 | POP_Y 182 | JSR S_DEC_SP 183 | RTS 184 | 185 | ;; S_POP_X() -> BYTE 186 | ;; Pops the X register from the software stack. Assumes it 187 | ;; was pushed by S_PUSH_X, which actually pushes X twice to 188 | ;; maintain stack alignment. 189 | S_POP_X: 190 | JSR S_POP_A 191 | TAX 192 | RTS 193 | 194 | ;; S_POP_Y() -> BYTE 195 | ;; Pops the Y register from the software stack. Assumes it 196 | ;; was pushed by S_PUSH_Y, which actually pushes Y twice to 197 | ;; maintain stack alignment. 198 | S_POP_Y: 199 | JSR S_POP_A 200 | TAY 201 | RTS 202 | 203 | ;; S_POP_A() -> BYTE 204 | ;; Pops the A register from the software stack. Assumes it 205 | ;; was pushed by S_PUSH_A, which actually pushes A twice to 206 | ;; maintain stack alignment. 207 | S_POP_A: 208 | PUSH_Y 209 | JSR S_INC_SP 210 | LDY #-3 211 | LDA (SSP),Y 212 | POP_Y 213 | RTS 214 | 215 | ;; S_PUSH_PTR(P :: PTR) -> PTR 216 | ;; Pushes a 16-bit pointer value onto the stack. 217 | ;; The pointer is taken from the PTR register. 218 | S_PUSH_PTR: 219 | PUSH_Y 220 | LDY #0 221 | LDA PTR : STA (SSP),Y : INY 222 | LDA PTR+1 : STA (SSP),Y 223 | POP_Y 224 | JSR S_DEC_SP 225 | RTS 226 | 227 | ;; S_POP_PTR() -> PTR 228 | ;; Pops a 16-bit pointer value off the stack, storing it 229 | ;; in the PTR location. 230 | S_POP_PTR: 231 | PUSH_Y 232 | LDY #0 233 | LDA (SSP),Y 234 | STA PTR 235 | INY 236 | LDA (SSP),Y 237 | STA PTR+1 238 | POP_Y 239 | RTS 240 | 241 | ;; S_INC_SP() -> NONE 242 | ;; Increments the software stack pointer by two. 243 | S_INC_SP: 244 | LDA SSP 245 | CLC 246 | ADC #2 ; NOTE could optimize with 2xINC 247 | STA SSP 248 | BCC S_INC_SP_END ; If ZF is set then low byte addition wrapped 249 | INC SSP+1 250 | S_INC_SP_END: 251 | RTS 252 | 253 | ;; S_DEC_SP() -> NONE 254 | ;; Decrements the software stack pointer two. 255 | S_DEC_SP: 256 | LDA SSP 257 | SEC 258 | SBC #2 ; NOTE could optimize with 2xDEC 259 | STA SSP 260 | BCS S_DEC_SP_END ; If NF is set, low byte subtraction wrapped 261 | DEC SSP+1 262 | S_DEC_SP_END: 263 | RTS 264 | 265 | ;; Marks the end of the code section; used to determine heap start. 266 | ;; MUST be after all code! 267 | CODE_END 268 | --------------------------------------------------------------------------------