nasm/stepA_mal.asm

   1 ;;
   2 ;; nasm -felf64 stepA_mal.asm && ld stepA_mal.o && ./a.out
   3 ;;
   4 ;; Calling convention: Address of input is in RSI
   5 ;;                     Address of return value is in RAX
   6 ;;
   7
   8 global  _start
   9
  10 %include "types.asm"            ; Data types, memory
  11 %include "env.asm"              ; Environment type
  12 %include "system.asm"           ; System calls
  13 %include "reader.asm"           ; String -> Data structures
  14 %include "core.asm"             ; Core functions
  15 %include "printer.asm"          ; Data structures -> String
  16 %include "exceptions.asm"       ; Error handling
  17
  18 section .bss
  19
  20 ;; Top-level (REPL) environment
  21 repl_env:resq 1
  22
  23 section .data
  24
  25 ;; ------------------------------------------
  26 ;; Fixed strings for printing
  27
  28         static prompt_string, db 10,"user> "      ; The string to print at the prompt
  29
  30         static error_string, db 27,'[31m',"Error",27,'[0m',": "
  31
  32         static not_found_string, db " not found"
  33
  34         static def_missing_arg_string, db "missing argument to def!",10
  35
  36         static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10
  37
  38         static defmacro_expecting_function_string, db "defmacro expects function",10
  39
  40         static let_missing_bindings_string, db "let* missing bindings",10
  41
  42         static let_bindings_list_string, db "let* expected a list or vector of bindings",10
  43
  44         static let_bind_symbol_string, db "let* expected a symbol in bindings list",10
  45
  46         static let_bind_value_string, db "let* missing value in bindings list",10
  47
  48         static let_missing_body_string, db "let* missing body",10
  49         static eval_list_not_function, db "list does not begin with a function",10
  50
  51         static if_missing_condition_string, db "missing condition in if expression",10
  52
  53         static try_missing_catch, db "try* missing catch*"
  54         static catch_missing_symbol, db "catch* missing symbol"
  55         static catch_missing_form, db "catch* missing form"
  56
  57 ;; Symbols used for comparison
  58
  59         static_symbol def_symbol, 'def!'
  60         static_symbol let_symbol, 'let*'
  61         static_symbol do_symbol, 'do'
  62         static_symbol if_symbol, 'if'
  63         static_symbol fn_symbol, 'fn*'
  64         static_symbol defmacro_symbol, 'defmacro!'
  65         static_symbol macroexpand_symbol, 'macroexpand'
  66         static_symbol try_symbol, 'try*'
  67         static_symbol catch_symbol, 'catch*'
  68
  69         static_symbol argv_symbol, '*ARGV*'
  70
  71         static_symbol quote_symbol, 'quote'
  72         static_symbol quasiquote_symbol, 'quasiquote'
  73         static_symbol unquote_symbol, 'unquote'
  74         static_symbol splice_unquote_symbol, 'splice-unquote'
  75         static_symbol concat_symbol, 'concat'
  76         static_symbol cons_symbol, 'cons'
  77
  78 ;; Startup string. This is evaluated on startup
  79         static mal_startup_string, db "(do \
  80 (def! not (fn* (a) (if a false true))) \
  81 (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34,"  (slurp f) ",34,")",34," ))))) \
  82 (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \
  83 (def! inc (fn* [x] (+ x 1))) \
  84 (def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str ",34,"G__",34," (swap! counter inc)))))) \
  85 (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) \
  86 (def! *host-language* ",34,"nasm",34,")\
  87 (def! conj nil)\
  88 )"
  89
  90 ;; Command to run, appending the name of the script to run
  91         static run_script_string, db "(load-file ",34
  92
  93 ;; Command to run at start of REPL
  94         static mal_startup_header, db "(println (str ",34,"Mal [",34," *host-language* ",34,"]",34,"))"
  95
  96 section .text
  97
  98 ;; ----------------------------------------------
  99 ;; Evaluates a form
 100 ;;
 101 ;; Inputs: RSI   Form to evaluate
 102 ;;         RDI   Environment
 103 ;;
 104 eval_ast:
 105         mov r15, rdi             ; Save Env in r15
 106
 107         ; Check the type
 108         mov al, BYTE [rsi]
 109
 110         ; Check if this is a list
 111         mov ah, al
 112         and ah, container_mask
 113         cmp ah, container_list
 114         je .list
 115
 116         cmp ah, container_map
 117         je .map
 118
 119         cmp ah, container_vector
 120         je .vector
 121
 122         ; Not a list, map or vector
 123         cmp ah, container_symbol
 124         je .symbol
 125
 126         ; Not a symbol, list, map or vector
 127         call incref_object      ; Increment reference count
 128
 129         mov rax, rsi
 130         ret
 131
 132 .symbol:
 133         ; Check if first character of symbol is ':'
 134         mov al, BYTE [rsi + Array.data]
 135         cmp al, ':'
 136         je .keyword
 137
 138         ; look in environment
 139         push rsi
 140         xchg rsi, rdi
 141         ; symbol is the key in rdi
 142         ; Environment in rsi
 143         call env_get
 144         pop rsi
 145         je .done                ; result in RAX
 146
 147         ; Not found, throw an error
 148         mov r11, rsi        ; Symbol in R11
 149
 150         call string_new
 151         mov rsi, rax            ; New string in RSI
 152
 153         mov cl, 39              ; quote '
 154         call string_append_char
 155
 156         mov rdx, r11            ; symbol
 157         call string_append_string
 158
 159         mov cl, 39
 160         call string_append_char
 161
 162         mov r11, rsi
 163
 164         mov rsi, not_found_string
 165         mov edx, not_found_string.len
 166         call raw_to_string ; ' not found'
 167
 168         mov r12, rax
 169
 170         mov rdx, rax
 171         mov rsi, r11
 172         call string_append_string
 173
 174         mov r11, rsi
 175         mov rsi, r12
 176         call release_array
 177         mov rsi, r11
 178
 179         jmp error_throw
 180
 181         ; ------------------------------
 182
 183 .keyword:
 184         ; Just return keywords unaltered
 185         call incref_object
 186         mov rax, rsi
 187         ret
 188
 189         ; ------------------------------
 190 .list:
 191         ; Evaluate each element of the list
 192         ;
 193         xor r8, r8              ; The list to return
 194         ; r9 contains head of list
 195
 196 .list_loop:
 197         mov al, BYTE [rsi]      ; Check type
 198         mov ah, al
 199         and ah, content_mask
 200         cmp ah, content_pointer
 201         je .list_pointer
 202
 203         ; A value in RSI, so copy
 204
 205         call alloc_cons
 206         mov bl, BYTE [rsi]
 207         and bl, content_mask
 208         add bl, (block_cons + container_list)
 209         mov [rax], BYTE bl      ; set type
 210         mov rbx, [rsi + Cons.car]
 211         mov [rax + Cons.car], rbx ; copy value
 212
 213         ; Result in RAX
 214         jmp .list_append
 215
 216 .list_pointer:
 217         ; List element is a pointer to something
 218         push rsi
 219         push r8
 220         push r9
 221         push r15                  ; Env
 222         mov rdi, [rsi + Cons.car] ; Get the address
 223         mov rsi, r15
 224
 225         call incref_object      ; Environment increment refs
 226         xchg rsi, rdi           ; Env in RDI, AST in RSI
 227
 228         call incref_object      ; AST increment refs
 229
 230         call eval             ; Evaluate it, result in rax
 231         pop r15
 232         pop r9
 233         pop r8
 234         pop rsi
 235
 236         ; Check the type it's evaluated to
 237         mov bl, BYTE [rax]
 238         mov bh, bl
 239         and bh, (block_mask + container_mask)
 240         cmp bh, (block_cons + container_value)
 241         je .list_eval_value
 242
 243         ; Not a value, so need a pointer to it
 244         push rax
 245         call alloc_cons
 246         mov [rax], BYTE (block_cons + container_list + content_pointer)
 247         pop rbx                 ; Address to point to
 248         mov [rax + Cons.car], rbx
 249         jmp .list_append
 250
 251 .list_eval_value:
 252         ; Got value in RAX, so copy
 253         push rax
 254         call alloc_cons         ; Copy in RAX
 255         pop rbx                 ; Value to copy in RBX
 256         mov cl, BYTE [rbx]
 257         and cl, content_mask
 258         or  cl, (block_cons + container_list)
 259         mov [rax], BYTE cl      ; set type
 260         mov rcx, [rbx + Cons.car]
 261         mov [rax + Cons.car], rcx ; copy value
 262
 263         ; Release the value in RBX
 264         push rsi
 265         push rax
 266         mov rsi, rbx
 267         call release_cons
 268         pop rax
 269         pop rsi
 270
 271         ; Fall through to .list_append
 272 .list_append:
 273         ; In RAX
 274
 275         cmp r8, 0               ; Check if this is the first
 276         je .list_first
 277
 278         ; append to r9
 279         mov [r9 + Cons.cdr], rax
 280         mov [r9 + Cons.typecdr], BYTE content_pointer
 281         mov r9, rax
 282         jmp .list_next
 283
 284 .list_first:
 285         mov r8, rax
 286         mov r9, rax
 287         ; fall through to .list_next
 288
 289 .list_next:
 290         ; Check if there's another
 291         mov al, BYTE [rsi + Cons.typecdr]
 292         cmp al, content_pointer
 293         jne .list_done          ; finished list
 294         mov rsi, [rsi + Cons.cdr] ; next in list
 295         jmp .list_loop
 296
 297 .list_done:
 298         mov rax, r8            ; Return the list
 299         ret
 300
 301         ; ---------------------
 302 .map:
 303         ; Create a new map, evaluating all the values
 304
 305         ; Check if the map is empty
 306         cmp al, maltype_empty_map
 307         jne .map_not_empty
 308
 309         ; map empty. Just return it
 310         call incref_object
 311         mov rax, rsi
 312         ret
 313
 314 .map_not_empty:
 315
 316         mov r10, rsi            ; input in R10
 317         xor r12, r12            ; New map in r12
 318
 319         ; Now loop through each key-value pair
 320         ; NOTE: This method relies on the implementation
 321         ; of map as a list
 322
 323 .map_loop:
 324         ; Copy the key
 325         call alloc_cons         ; New Cons in RAX
 326
 327         mov bl, [r10 + Cons.typecar] ; Type in BL
 328         mov [rax + Cons.typecar], bl
 329         mov rcx, [r10 + Cons.car] ; Value in RCX
 330         mov [rax + Cons.car], rcx
 331
 332         ; Check the type of the key
 333         and bl, content_mask
 334         cmp bl, content_pointer
 335         jne .map_got_key        ; a value
 336
 337         ; a pointer, so increment reference count
 338         mov bx, WORD [rcx + Cons.refcount]
 339         inc bx
 340         mov [rcx + Cons.refcount], WORD bx
 341
 342 .map_got_key:
 343         cmp r12,0
 344         jne .append_key
 345
 346         ; First key
 347         mov r12, rax
 348         mov r13, rax
 349         jmp .map_value
 350
 351 .append_key:
 352         ; Appending to previous value in r13
 353         mov [r13 + Cons.typecdr], BYTE content_pointer
 354         mov [r13 + Cons.cdr], rax
 355         mov r13, rax
 356
 357 .map_value:
 358         ; Check that we have a value
 359         mov al, BYTE [r10 + Cons.typecdr]
 360         cmp al, content_pointer
 361         jne .map_error_missing_value
 362         mov r10, [r10 + Cons.cdr]
 363
 364         ; Now got value in r10
 365
 366         ; Check the type of the value
 367         mov bl, [r10 + Cons.typecar] ; Type in BL
 368         and bl, content_mask
 369         cmp bl, content_pointer
 370         je .map_value_pointer
 371
 372         ; Not a pointer, so make a copy
 373         call alloc_cons
 374         mov bl, [r10 + Cons.typecar]
 375         mov [rax + Cons.typecar], bl
 376         mov rcx, [r10 + Cons.car]
 377         mov [rax + Cons.car], rcx
 378
 379         jmp .map_got_value
 380 .map_value_pointer:
 381         ; A pointer, so need to evaluate
 382         push r10                ; Input
 383         push r12                ; start of result
 384         push r13                ; Current head of result
 385         push r15                ; Env
 386         mov rsi, [r10 + Cons.car] ; Get the address
 387         mov rdi, r15
 388
 389         xchg rsi, rdi
 390         call incref_object      ; Environment increment refs
 391         xchg rsi, rdi
 392
 393         call incref_object
 394
 395         call eval               ; Evaluate it, result in rax
 396         pop r15
 397         pop r13
 398         pop r12
 399         pop r10
 400
 401         ; Check the type it's evaluated to
 402         mov bl, BYTE [rax]
 403         mov bh, bl
 404         and bh, (block_mask + container_mask)
 405         cmp bh, (block_cons + container_value)
 406
 407         jne .map_eval_pointer
 408
 409         ; A value, so just change the type to a map
 410         and bl, content_mask
 411         add bl, (block_cons + container_map)
 412         mov [rax], BYTE bl
 413         jmp .map_got_value
 414
 415 .map_eval_pointer:
 416         ; Not a value, so need a pointer to it
 417         push rax
 418         call alloc_cons
 419         mov [rax], BYTE (block_cons + container_map + content_pointer)
 420         pop rbx                 ; Address to point to
 421         mov [rax + Cons.car], rbx
 422
 423 .map_got_value:
 424         ; Append RAX to list in R13
 425         mov [r13 + Cons.typecdr], BYTE content_pointer
 426         mov [r13 + Cons.cdr], rax
 427         mov r13, rax
 428
 429         ; Check if there's another key
 430         mov al, BYTE [r10 + Cons.typecdr]
 431         cmp al, content_pointer
 432         jne .map_done          ; finished map
 433         mov r10, [r10 + Cons.cdr] ; next in map
 434         jmp .map_loop
 435
 436 .map_done:
 437         mov rax, r12
 438         ret
 439
 440 .map_error_missing_value:
 441         mov rax, r12
 442         ret
 443
 444         ; ------------------------------
 445 .vector:
 446         ; Evaluate each element of the vector
 447         ;
 448         xor r8, r8              ; The vector to return
 449         ; r9 contains head of vector
 450
 451 .vector_loop:
 452         mov al, BYTE [rsi]      ; Check type
 453         mov ah, al
 454         and ah, content_mask
 455         cmp ah, content_pointer
 456         je .vector_pointer
 457
 458         ; A value, so copy
 459         call alloc_cons
 460         mov bl, BYTE [rsi]
 461         and bl, content_mask
 462         add bl, (block_cons + container_vector)
 463         mov [rax], BYTE bl      ; set type
 464         mov rbx, [rsi + Cons.car]
 465         mov [rax + Cons.car], rbx ; copy value
 466
 467         ; Result in RAX
 468         jmp .vector_append
 469
 470 .vector_pointer:
 471         ; Vector element is a pointer to something
 472         push rsi
 473         push r8
 474         push r9
 475         push r15                  ; Env
 476         mov rsi, [rsi + Cons.car] ; Get the address
 477         mov rdi, r15
 478
 479         xchg rsi, rdi
 480         call incref_object      ; Environment increment refs
 481         xchg rsi, rdi
 482
 483         call incref_object
 484
 485         call eval             ; Evaluate it, result in rax
 486         pop r15
 487         pop r9
 488         pop r8
 489         pop rsi
 490
 491         ; Check the type it's evaluated to
 492         mov bl, BYTE [rax]
 493         mov bh, bl
 494         and bh, (block_mask + container_mask)
 495         cmp bh, (block_cons + container_value)
 496         je .vector_eval_value
 497
 498         ; Not a value, so need a pointer to it
 499         push rax
 500         call alloc_cons
 501         mov [rax], BYTE (block_cons + container_vector + content_pointer)
 502         pop rbx                 ; Address to point to
 503         mov [rax + Cons.car], rbx
 504         jmp .vector_append
 505
 506 .vector_eval_value:
 507         ; Got value in RAX, so copy
 508         push rax
 509         call alloc_cons         ; Copy in RAX
 510         pop rbx                 ; Value to copy in RBX
 511         mov cl, BYTE [rbx]
 512         and cl, content_mask
 513         or  cl, (block_cons + container_vector)
 514         mov [rax], BYTE cl      ; set type
 515         mov rcx, [rbx + Cons.car]
 516         mov [rax + Cons.car], rcx ; copy value
 517
 518         ; Release the value in RBX
 519         push rsi
 520         push rax
 521         mov rsi, rbx
 522         call release_cons
 523         pop rax
 524         pop rsi
 525
 526 .vector_append:
 527         ; In RAX
 528
 529         cmp r8, 0               ; Check if this is the first
 530         je .vector_first
 531
 532         ; append to r9
 533         mov [r9 + Cons.cdr], rax
 534         mov [r9 + Cons.typecdr], BYTE content_pointer
 535         mov r9, rax
 536         jmp .vector_next
 537
 538 .vector_first:
 539         mov r8, rax
 540         mov r9, rax
 541         ; fall through to .vector_next
 542
 543 .vector_next:
 544         ; Check if there's another
 545         mov al, BYTE [rsi + Cons.typecdr]
 546         cmp al, content_pointer
 547         jne .vector_done          ; finished vector
 548         mov rsi, [rsi + Cons.cdr] ; next in vector
 549         jmp .vector_loop
 550
 551 .vector_done:
 552         mov rax, r8            ; Return the vector
 553         ret
 554
 555         ; ---------------------
 556 .done:
 557         ret
 558
 559
 560
 561 ;; Comparison of symbols for eval function
 562 ;; Compares the symbol in RSI with specified symbol
 563 ;; Preserves RSI and RBX
 564 ;; Modifies RDI
 565 %macro eval_cmp_symbol 1
 566         push rsi
 567         push rbx
 568         mov rsi, rbx
 569         mov rdi, %1
 570         call compare_char_array
 571         pop rbx
 572         pop rsi
 573         test rax, rax           ; ZF set if rax = 0 (equal)
 574 %endmacro
 575
 576 ;; ----------------------------------------------------
 577 ;; Evaluates a form
 578 ;;
 579 ;; Input: RSI   AST to evaluate   [ Released ]
 580 ;;        RDI   Environment       [ Released ]
 581 ;;
 582 ;; Returns: Result in RAX
 583 ;;
 584 ;; Note: Both the form and environment will have their reference count
 585 ;; reduced by one (released). This is for tail call optimisation (Env),
 586 ;; quasiquote and macroexpand (AST)
 587 ;;
 588 eval:
 589         mov r15, rdi            ; Env
 590
 591         push rsi                ; AST pushed, must be popped before return
 592
 593         ; Check type
 594         mov al, BYTE [rsi]
 595         cmp al, maltype_empty_list
 596         je .empty_list           ; empty list, return unchanged
 597
 598         and al, container_mask
 599         cmp al, container_list
 600         je .list
 601
 602         ; Not a list. Evaluate and return
 603         call eval_ast
 604         jmp .return             ; Releases Env
 605
 606         ; --------------------
 607 .list:
 608         ; A list
 609
 610         ; Macro expand
 611         pop rax ; Old AST, discard from stack
 612         call macroexpand        ; Replaces RSI
 613         push rsi ; New AST
 614
 615         ; Check if RSI is a list, and if
 616         ; the first element is a symbol
 617         mov al, BYTE [rsi]
 618
 619         ; Check type
 620         mov al, BYTE [rsi]
 621         cmp al, maltype_empty_list
 622         je .empty_list           ; empty list, return unchanged
 623
 624         mov ah, al
 625         and ah, container_mask
 626         cmp ah, container_list
 627         je .list_still_list
 628
 629         ; Not a list, so call eval_ast on it
 630         mov rdi, r15            ; Environment
 631         call eval_ast
 632         jmp .return
 633
 634 .list_still_list:
 635         and al, content_mask
 636         cmp al, content_pointer
 637         jne .list_eval
 638
 639         mov rbx, [rsi + Cons.car]
 640         mov al, BYTE [rbx]
 641         cmp al, maltype_symbol
 642         jne .list_eval
 643
 644         ; Is a symbol, address in RBX
 645
 646         ; Compare against special form symbols
 647
 648         eval_cmp_symbol def_symbol ; def!
 649         je .def_symbol
 650
 651         eval_cmp_symbol let_symbol ; let*
 652         je .let_symbol
 653
 654         eval_cmp_symbol do_symbol ; do
 655         je .do_symbol
 656
 657         eval_cmp_symbol if_symbol ; if
 658         je .if_symbol
 659
 660         eval_cmp_symbol fn_symbol ; fn
 661         je .fn_symbol
 662
 663         eval_cmp_symbol quote_symbol ; quote
 664         je .quote_symbol
 665
 666         eval_cmp_symbol quasiquote_symbol ; quasiquote
 667         je .quasiquote_symbol
 668
 669         eval_cmp_symbol defmacro_symbol ; defmacro!
 670         je .defmacro_symbol
 671
 672         eval_cmp_symbol macroexpand_symbol ; macroexpand
 673         je .macroexpand_symbol
 674
 675         eval_cmp_symbol try_symbol ; try*
 676         je .try_symbol
 677
 678         ; Unrecognised
 679         jmp .list_eval
 680
 681
 682         ; -----------------------------
 683
 684 .defmacro_symbol:
 685         mov r9, 1
 686         jmp .def_common
 687 .def_symbol:
 688         xor r9, r9        ; Set R9 to 0
 689 .def_common:
 690         ; Define a new symbol in current environment
 691         ; If R9 is set to 1 then defmacro
 692
 693         ; Next item should be a symbol
 694         mov al, BYTE [rsi + Cons.typecdr]
 695         cmp al, content_pointer
 696         jne .def_error_missing_arg
 697         mov rsi, [rsi + Cons.cdr]
 698
 699         ; Now should have a symbol
 700
 701         mov al, BYTE [rsi + Cons.typecar]
 702         and al, content_mask
 703         cmp al, content_pointer
 704         jne .def_error_expecting_symbol
 705         mov r8, [rsi + Cons.car] ; Symbol (?)
 706
 707         mov al, BYTE [r8]
 708         cmp al, maltype_symbol
 709         jne .def_error_expecting_symbol
 710
 711         ; R8 now contains a symbol
 712
 713         ; expecting a value or pointer next
 714         mov al, BYTE [rsi + Cons.typecdr]
 715         cmp al, content_pointer
 716         jne .def_error_missing_arg
 717         mov rsi, [rsi + Cons.cdr]
 718
 719         ; Check if this is a pointer
 720         mov al, BYTE [rsi]
 721         mov ah, al
 722         and ah, content_mask
 723         cmp ah, content_pointer
 724         je .def_pointer
 725
 726         ; A value, so copy
 727
 728         ; Test if this is defmacro!
 729         test r9, r9
 730         jnz .defmacro_not_function
 731
 732         push rax
 733         call alloc_cons
 734         pop rbx                 ; BL now contains type
 735         and bl, content_mask
 736         add bl, (block_cons + container_value)
 737         mov [rax], BYTE bl
 738         mov rcx, [rsi + Cons.car]
 739         mov [rax + Cons.car], rcx
 740         mov rsi, rax
 741
 742         jmp .def_got_value
 743
 744 .def_pointer:
 745         ; A pointer, so evaluate
 746
 747         ; This may throw an error, so define a handler
 748
 749         push r8                 ; the symbol
 750         push r15                ; Env
 751         push r9
 752         mov rsi, [rsi + Cons.car] ; Pointer
 753         mov rdi, r15
 754
 755         xchg rsi, rdi
 756         call incref_object      ; Environment increment refs
 757         xchg rsi, rdi           ; since it will be decremented by eval
 758
 759         call incref_object      ; AST increment refs
 760
 761         call eval
 762         mov rsi, rax
 763
 764         pop r9
 765
 766         ; If this is defmacro, and the object in RSI is a function,
 767         ; then change to a macro
 768         test r9, r9
 769         jz .def_not_macro       ; Not defmacro
 770
 771         ; Check RSI
 772         mov al, BYTE [rsi]
 773         cmp al, maltype_function
 774         jne .defmacro_not_function
 775
 776         ; Got a function, change to macro
 777         mov [rsi], BYTE maltype_macro
 778
 779 .def_not_macro:
 780
 781         pop r15
 782         pop r8
 783
 784 .def_got_value:
 785         ; Symbol in R8, value in RSI
 786         mov rdi, r8             ; key (symbol)
 787         mov rcx, rsi            ; Value
 788         mov rsi, r15            ; Environment
 789         call env_set
 790
 791         mov rax, rcx
 792         jmp .return
 793
 794 .def_error_missing_arg:
 795         mov rsi, def_missing_arg_string
 796         mov rdx, def_missing_arg_string.len
 797         jmp .def_handle_error
 798
 799 .def_error_expecting_symbol:
 800         mov rsi, def_expecting_symbol_string
 801         mov rdx, def_expecting_symbol_string.len
 802         jmp .def_handle_error
 803
 804 .defmacro_not_function:
 805         mov rsi, defmacro_expecting_function_string
 806         mov rdx, defmacro_expecting_function_string.len
 807         jmp .def_handle_error
 808
 809 .def_handle_error:
 810         push rsi
 811         push rdx
 812         print_str_mac error_string   ; print 'Error: '
 813
 814         pop rdx
 815         pop rsi
 816         call print_rawstring    ; print message
 817
 818         xor rsi, rsi            ; no object to throw
 819         jmp error_throw         ; No return
 820
 821         ; -----------------------------
 822 .let_symbol:
 823         ; Create a new environment
 824
 825         mov r11, rsi            ; Let form in R11
 826
 827         mov rsi, r15            ; Outer env
 828         call env_new            ; Increments R15's ref count
 829         mov r14, rax            ; New environment in R14
 830
 831         mov rsi, r15
 832         call release_object     ; Decrement R15 ref count
 833
 834         ; Second element should be the bindings
 835
 836         mov al, BYTE [r11 + Cons.typecdr]
 837         cmp al, content_pointer
 838         jne .let_error_missing_bindings
 839         mov r11, [r11 + Cons.cdr]
 840
 841         mov al, BYTE [r11]
 842         and al, content_mask
 843         cmp al, content_pointer
 844         jne .let_error_bindings_list
 845
 846         mov r12, [r11 + Cons.car] ; should be bindings list
 847         mov al, BYTE [r12]
 848         and al, (block_mask + container_mask)
 849         ; Can be either a list or vector
 850         cmp al, block_cons + container_list
 851         je .let_bind_loop
 852         cmp al, block_cons + container_vector
 853         je .let_bind_loop
 854
 855         ; Not a list or vector
 856         jmp .let_error_bindings_list
 857
 858 .let_bind_loop:
 859         ; R12 now contains a list with an even number of items
 860         ; The first should be a symbol, then a value to evaluate
 861
 862         ; Get the symbol
 863         mov al, BYTE [r12]
 864         and al, content_mask
 865         cmp al, content_pointer
 866         jne .let_error_bind_symbol
 867
 868         mov r13, [r12 + Cons.car] ; Symbol (?)
 869         mov al, BYTE [r13]
 870         cmp al, maltype_symbol
 871         jne .let_error_bind_symbol
 872
 873         ; R13 now contains a symbol to bind
 874         ; The next item in the bindings list (R12)
 875         ; should be a value or expression to evaluate
 876
 877         mov al, BYTE [r12 + Cons.typecdr]
 878         and al, content_mask
 879         cmp al, content_pointer
 880         jne .let_error_bind_value
 881         mov r12, [r12 + Cons.cdr]
 882
 883         ; got value in R12
 884
 885         ; Check the type of the value
 886         mov bl, [r12 + Cons.typecar] ; Type in BL
 887         and bl, content_mask
 888         cmp bl, content_pointer
 889         je .let_value_pointer
 890
 891         ; Not a pointer, so make a copy
 892         call alloc_cons
 893         mov bl, [r12 + Cons.typecar]
 894         and bl, content_mask
 895         ;or bl, (block_cons + container_value) ; 0
 896         mov [rax + Cons.typecar], bl
 897         mov rcx, [r12 + Cons.car]
 898         mov [rax + Cons.car], rcx
 899
 900         jmp .let_got_value
 901
 902 .let_value_pointer:
 903         ; A pointer, so need to evaluate
 904         push r11                 ; let* form list
 905         push r12                 ; Position in bindings list
 906         push r13                 ; symbol to bind
 907         push r14                 ; new environment
 908
 909         mov rsi, r14
 910         call incref_object
 911         mov rdi, r14
 912
 913         mov rsi, [r12 + Cons.car] ; Get the address
 914
 915         call incref_object      ; Increment ref count of AST
 916
 917         call eval               ; Evaluate it, result in rax
 918         pop r14
 919         pop r13
 920         pop r12
 921         pop r11
 922
 923 .let_got_value:
 924
 925         mov rsi, r14            ; Env
 926         mov rdi, r13            ; key
 927         mov rcx, rax            ; value
 928         call env_set
 929
 930         ; Release the value
 931         mov rsi, rcx            ; The value
 932         call release_object
 933
 934         ; Check if there are more bindings
 935         mov al, BYTE [r12 + Cons.typecdr]
 936         cmp al, content_pointer
 937         jne .let_done_binding
 938         mov r12, [r12 + Cons.cdr] ; Next
 939         jmp .let_bind_loop
 940
 941 .let_done_binding:
 942         ; Done bindings.
 943         ; Evaluate next item in let* form in new environment
 944
 945         mov al, BYTE [r11 + Cons.typecdr]
 946         cmp al, content_pointer
 947         jne .let_error_missing_body
 948         mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate
 949         ; Check type of the value
 950         mov al, BYTE [r11]
 951         and al, block_mask + content_mask
 952         cmp al, content_pointer
 953         je .body_pointer
 954
 955         ; Just a value, so copy
 956         call alloc_cons
 957         mov bl, BYTE [r11]
 958         and bl, content_mask
 959         mov [rax], BYTE bl      ; set type
 960         mov rbx, [r11 + Cons.car]
 961         mov [rax + Cons.car], rbx ; copy value
 962         jmp .let_done
 963
 964 .body_pointer:
 965         ; Evaluate using new environment
 966
 967         mov rsi, [r11 + Cons.car] ; Object pointed to
 968         call incref_object        ; will be released by eval
 969
 970         mov r11, rsi              ; save new AST
 971         pop rsi                   ; Old AST
 972         call release_object
 973         mov rsi, r11            ; New AST
 974
 975         mov rdi, r14            ; New environment
 976
 977         jmp eval                ; Tail call
 978         ; Note: eval will release the new environment on return
 979
 980 .let_done:
 981         ; Release the new environment
 982         push rax
 983         mov rsi, r14
 984         call release_object
 985         pop rax
 986
 987         ; Release the AST
 988         pop rsi
 989         push rax
 990         call release_object
 991         pop rax
 992         ret                     ; already released env
 993
 994 .let_error_missing_bindings:
 995         mov rsi, let_missing_bindings_string
 996         mov rdx, let_missing_bindings_string.len
 997         jmp .let_handle_error
 998
 999 .let_error_bindings_list:       ; expected a list or vector, got something else
1000         mov rsi, let_bindings_list_string
1001         mov rdx, let_bindings_list_string.len
1002         jmp .let_handle_error
1003
1004 .let_error_bind_symbol:         ; expected a symbol, got something else
1005         mov rsi, let_bind_symbol_string
1006         mov rdx, let_bind_symbol_string.len
1007         jmp .let_handle_error
1008
1009 .let_error_bind_value:          ; Missing value in binding list
1010         mov rsi, let_bind_value_string
1011         mov rdx, let_bind_value_string.len
1012         jmp .let_handle_error
1013
1014 .let_error_missing_body:        ; Missing body to evaluate
1015         mov rsi, let_missing_body_string
1016         mov rdx, let_missing_body_string.len
1017         jmp .let_handle_error
1018
1019 .let_handle_error:
1020         push r11                ; For printing later
1021
1022         push rsi
1023         push rdx
1024
1025         print_str_mac error_string   ; print 'Error: '
1026
1027         pop rdx
1028         pop rsi
1029         call print_rawstring    ; print message
1030
1031         pop rsi                 ; let* form
1032         jmp error_throw         ; No return
1033
1034         ; -----------------------------
1035
1036 .do_symbol:
1037         mov r11, rsi            ; do form in RSI
1038         ; Environment in R15
1039
1040         ; Check if there is a body
1041         mov al, BYTE [r11 + Cons.typecdr]
1042         cmp al, content_pointer
1043         jne .do_no_body         ; error
1044
1045         mov r11, [r11 + Cons.cdr] ; Body in R11
1046
1047 .do_symbol_loop:
1048
1049         ; Need to test if this is the last form
1050         ; so we can handle tail call
1051
1052         mov bl, BYTE [r11 + Cons.typecdr]
1053         cmp bl, content_pointer
1054         jne .do_body_last ; Last expression
1055
1056         ; not the last expression
1057
1058         ; Check if this is a value or pointer
1059         mov al, BYTE [r11]
1060         and al, block_mask + content_mask
1061         cmp al, content_pointer
1062         jne .do_next            ; A value, so skip
1063
1064         ; A pointer, so evaluate
1065
1066         push r15
1067         push r11
1068
1069         mov rsi, r15
1070         call incref_object      ; Increase Env reference
1071                                 ; since eval will release Env
1072
1073         mov rsi, [r11 + Cons.car]  ; Form
1074         call incref_object         ; Increment ref count since eval will release
1075
1076         mov rdi, r15            ; Env
1077         call eval               ; Result in RAX
1078
1079         ; Another form after this.
1080         ; Discard the result of the last eval
1081         mov rsi, rax
1082         call release_object
1083
1084         pop r11
1085         pop r15
1086
1087 .do_next:
1088         mov r11, [r11 + Cons.cdr] ; Next in list
1089
1090         jmp .do_symbol_loop
1091
1092 .do_body_last:
1093         ; The last form is in R11, which will be returned
1094
1095         ; Check if this is a value or pointer
1096         mov al, BYTE [r11]
1097         and al, block_mask + content_mask
1098         cmp al, content_pointer
1099         jne .do_body_value_return
1100         jmp .do_body_expr_return
1101
1102 .do_body_value_return:
1103         ; Got a value as last form (in R11).
1104         ; Copy and return
1105
1106         push rax                ; Type of value to return
1107
1108         ; release Env
1109         mov rsi, r15
1110         call release_object
1111
1112         ; Allocate a Cons object to hold value
1113         call alloc_cons
1114         pop rbx                 ; type in BL
1115         mov [rax], BYTE bl
1116         mov rbx, [r11 + Cons.car]
1117         mov [rax + Cons.car], rbx
1118
1119         ; release the AST
1120         pop rsi
1121         mov r15, rax            ; not modified by release
1122         call release_object
1123         mov rax, r15
1124
1125         ret
1126
1127 .do_body_expr_return:
1128         ; An expression to evaluate as the last form
1129         ; Tail call optimise, jumping to eval
1130         ; Don't increment Env reference count
1131
1132         mov rsi, [r11 + Cons.car]  ; new AST form
1133         call incref_object         ; This will be released by eval
1134
1135         mov r11, rsi              ; Save new AST
1136         pop rsi                   ; Remove old AST from stack
1137         call release_object
1138         mov rsi, r11
1139
1140         mov rdi, r15            ; Env
1141         jmp eval                ; Tail call
1142
1143 .do_no_body:
1144         ; No expressions to evaluate. Return nil
1145
1146         mov rsi, r15
1147         call release_object     ; Release Env
1148
1149         ; release the AST
1150         pop rsi
1151         call release_object
1152
1153         call alloc_cons
1154         mov [rax], BYTE maltype_nil
1155         mov [rax + Cons.typecdr], BYTE content_nil
1156         ret
1157
1158         ; -----------------------------
1159
1160 .if_symbol:
1161         mov r11, rsi            ; if form in R11
1162         ; Environment in R15
1163
1164         mov al, BYTE [r11 + Cons.typecdr]
1165         cmp al, content_pointer
1166         jne .if_no_condition
1167
1168         mov r11, [r11 + Cons.cdr] ; Should be a condition
1169
1170         ; Check if value or pointer
1171         mov al, BYTE [r11]
1172         and al, content_mask
1173         cmp al, content_pointer
1174         jne .if_cond_value
1175
1176         ; A pointer, so evaluate
1177
1178         push r15
1179         push r11
1180
1181         mov rsi, r15
1182         call incref_object      ; Increase Env reference
1183
1184         mov rsi, [r11 + Cons.car]  ; Form
1185         call incref_object         ; Increase Form/AST ref count
1186
1187         mov rdi, r15            ; Env
1188         call eval               ; Result in RAX
1189         pop r11
1190         pop r15
1191
1192         ; Get type of result
1193         mov bl, BYTE [rax]
1194
1195         ; release value
1196         push rbx
1197         mov rsi, rax
1198         call release_object
1199         pop rbx
1200
1201         ; Check type
1202         cmp bl, maltype_nil
1203         je .if_false
1204         cmp bl, maltype_false
1205         je .if_false
1206
1207         jmp .if_true
1208
1209 .if_cond_value:
1210
1211         ; A value
1212         cmp al, content_nil
1213         je .if_false
1214         cmp al, content_false
1215         je .if_false
1216
1217         jmp .if_true
1218
1219 .if_false:
1220         ; Skip the next item
1221         mov al, BYTE [r11 + Cons.typecdr]
1222         cmp al, content_pointer
1223         jne .return_nil
1224
1225         mov r11, [r11 + Cons.cdr]
1226
1227 .if_true:
1228         ; Get the next item in the list and evaluate it
1229         mov al, BYTE [r11 + Cons.typecdr]
1230         cmp al, content_pointer
1231         jne .return_nil         ; Nothing to return
1232
1233         mov r11, [r11 + Cons.cdr]
1234
1235         ; Check if value or pointer
1236         mov al, BYTE [r11]
1237         and al, content_mask
1238         cmp al, content_pointer
1239         je .if_got_pointer
1240
1241 .if_got_value:
1242         ; copy value in r11
1243         call alloc_cons
1244         mov bl, BYTE [r11]
1245         and bl, content_mask
1246         mov [rax], BYTE bl
1247         mov rbx, [r11 + Cons.car]
1248         mov [rax + Cons.car], rbx
1249
1250         jmp .return
1251
1252 .if_got_pointer:
1253         mov rsi, [r11 + Cons.car]  ; Form
1254         call incref_object        ; Will be released by eval
1255
1256         mov r11, rsi
1257         pop rsi
1258         call release_object     ; Release old AST
1259         mov rsi, r11            ; New AST
1260
1261         mov rdi, r15            ; Env
1262         jmp eval                ; Tail call
1263
1264 .if_no_condition:               ; just (if) without a condition
1265
1266         print_str_mac error_string
1267         print_str_mac if_missing_condition_string
1268
1269         ; Release environment
1270         mov rsi, r15
1271         call release_object
1272         xor rsi, rsi            ; No object to throw
1273         jmp error_throw
1274
1275 .return_nil:
1276         call alloc_cons
1277         mov [rax], BYTE maltype_nil
1278         mov [rax + Cons.typecdr], BYTE content_nil
1279
1280 .return:
1281         ; Release environment
1282         mov rsi, r15
1283         mov r15, rax            ; Save RAX (return value)
1284         call release_object
1285
1286         ; Release the AST
1287         pop rsi                 ; Pushed at start of eval
1288         call release_object
1289
1290         mov rax, r15            ; return value
1291         ret
1292
1293         ; -----------------------------
1294
1295 .fn_symbol:
1296         mov r11, rsi            ; fn form in R11
1297         ; Environment in R15
1298
1299         ; Get the binds and body of the function
1300         mov al, BYTE [r11 + Cons.typecdr]
1301         cmp al, content_pointer
1302         jne .fn_empty
1303
1304         mov r11, [r11 + Cons.cdr]
1305         mov al, BYTE [r11]
1306         and al, content_mask
1307         cmp al, content_pointer
1308         jne .fn_binds_not_list
1309
1310         mov r12, [r11 + Cons.car]  ; Should be binds list
1311         mov al, BYTE [r12]
1312         and al, (block_mask + container_mask)
1313         cmp al, (block_cons + container_list)
1314         je .fn_got_binds        ; Can be list
1315         cmp al, (block_cons + container_vector)
1316         je .fn_got_binds        ; or vector
1317         jmp .fn_binds_not_list
1318
1319 .fn_got_binds:
1320
1321         ; Next get the body of the function
1322         mov al, BYTE [r11 + Cons.typecdr]
1323         cmp al, content_pointer
1324         jne .fn_no_body
1325
1326         mov r11, [r11 + Cons.cdr]
1327         ; Check value or pointer
1328         mov al, BYTE [r11]
1329         and al, content_mask
1330         cmp al, content_pointer
1331         jne .fn_is_value        ; Body in r11
1332         mov r11, [r11 + Cons.car]
1333         jmp .fn_got_body
1334
1335 .fn_is_value:
1336         ; Body is just a value, no expression
1337         mov [r11], BYTE al      ; Mark as value, not list
1338
1339 .fn_got_body:
1340
1341         ; Now put into function type
1342         ;   Addr is "apply_fn", the address to call
1343         ;   Env in R15
1344         ;   Binds in R12
1345         ;   Body in R11
1346
1347         call alloc_cons
1348         mov [rax], BYTE (block_cons + container_function + content_function)
1349         mov rbx, apply_fn
1350         mov [rax + Cons.car], rbx ; Address of apply function
1351         mov [rax + Cons.typecdr], BYTE content_pointer
1352
1353         mov r13, rax            ; Return list in R13
1354
1355         ; Meta
1356
1357         call alloc_cons
1358         mov [rax], BYTE maltype_nil
1359         mov [rax + Cons.typecdr], BYTE content_pointer
1360
1361         mov [r13 + Cons.cdr], rax ; Append
1362         mov r14, rax
1363
1364         ; Env
1365
1366         call alloc_cons
1367         mov [rax], BYTE (block_cons + container_function + content_pointer)
1368         mov [rax + Cons.car], r15 ; Environment
1369         mov [rax + Cons.typecdr], BYTE content_pointer
1370
1371         mov [r14 + Cons.cdr], rax ; Append to list
1372         mov r14, rax
1373
1374         push rax
1375         mov rsi, r15
1376         call incref_object
1377         pop rax
1378
1379         ; Binds
1380
1381         call alloc_cons
1382         mov [rax], BYTE (block_cons + container_function + content_pointer)
1383         mov [rax + Cons.car], r12 ; Binds list
1384         mov [rax + Cons.typecdr], BYTE content_pointer
1385
1386         mov [r14 + Cons.cdr], rax ; Append to list
1387         mov r14, rax
1388
1389         push rax
1390         mov rsi, r12
1391         call incref_object
1392         pop rax
1393
1394         call alloc_cons
1395         mov [rax], BYTE (block_cons + container_function + content_pointer)
1396         mov [rax + Cons.car], r11 ; Body of function
1397
1398         mov [r14 + Cons.cdr], rax
1399
1400         mov rsi, r11
1401         call incref_object
1402
1403         mov rax, r13
1404         jmp .return
1405
1406 .fn_empty:
1407 .fn_binds_not_list:
1408 .fn_no_body:
1409
1410         call alloc_cons
1411         mov [rax], BYTE maltype_nil
1412         mov [rax + Cons.typecdr], BYTE content_nil
1413         jmp .return
1414
1415         ; -----------------------------
1416
1417 .quote_symbol:
1418         ; Just return the arguments in rsi cdr
1419
1420         mov al, BYTE [rsi + Cons.typecdr]
1421         cmp al, content_pointer
1422         jne .return_nil         ; quote empty, so return nil
1423
1424         mov rsi, [rsi + Cons.cdr]
1425
1426         ; Check if this is a value or pointer
1427         mov al, BYTE [rsi + Cons.typecar]
1428         and al, content_mask
1429         cmp al, content_pointer
1430         je .quote_pointer
1431
1432         ; RSI contains a value. Remove the list container
1433         mov [rsi + Cons.typecar], BYTE al
1434         call incref_object
1435         mov rax, rsi
1436         jmp .return
1437
1438 .quote_pointer:
1439         ; RSI contains a pointer, so get the object pointed to
1440         mov rsi, [rsi + Cons.car]
1441         call incref_object
1442         mov rax, rsi
1443         jmp .return
1444
1445         ; -----------------------------
1446
1447 .quasiquote_symbol:
1448         ; call quasiquote function with first argument
1449
1450         mov al, BYTE [rsi + Cons.typecdr]
1451         cmp al, content_pointer
1452         jne .return_nil         ; quasiquote empty, so return nil
1453
1454         mov r11, rsi            ; Save original AST in R11
1455
1456         mov rsi, [rsi + Cons.cdr]
1457
1458         ; Check if this is a value or pointer
1459         mov al, BYTE [rsi + Cons.typecar]
1460         and al, content_mask
1461         cmp al, content_pointer
1462         je .quasiquote_pointer
1463
1464         ; RSI contains a value. Remove the list container
1465         mov [rsi + Cons.typecar], BYTE al
1466         call incref_object
1467         mov rax, rsi
1468         jmp .return
1469
1470 .quasiquote_pointer:
1471         ; RSI contains a pointer, so get the object pointed to
1472         mov rsi, [rsi + Cons.car]
1473
1474         push r15                ; Environment
1475         ; Original AST already on stack
1476
1477         call quasiquote
1478         ; New AST in RAX
1479         pop rdi                 ; Environment
1480         pop rsi                 ; Old AST
1481
1482         mov r11, rax            ; New AST
1483         call release_object     ; Release old AST
1484         mov rsi, r11            ; New AST in RSI
1485
1486         jmp eval                ; Tail call
1487
1488         ; -----------------------------
1489 .macroexpand_symbol:
1490         ; Check if we have a second list element
1491
1492         mov al, BYTE [rsi + Cons.typecdr]
1493         cmp al, content_pointer
1494         jne .return_nil         ; No argument
1495
1496         mov rsi, [rsi + Cons.cdr]
1497
1498         ; Check if this is a value or pointer
1499         mov al, BYTE [rsi + Cons.typecar]
1500         and al, content_mask
1501         cmp al, content_pointer
1502         je .macroexpand_pointer
1503
1504         ; RSI contains a value. Remove the list container
1505         mov [rsi + Cons.typecar], BYTE al
1506         call incref_object
1507         mov rax, rsi
1508         jmp .return
1509
1510 .macroexpand_pointer:
1511         mov rsi, [rsi + Cons.car]
1512         call incref_object      ; Since RSI will be released
1513
1514         call macroexpand   ; May release and replace RSI
1515
1516         mov rax, rsi
1517         jmp .return ; Releases original AST
1518
1519         ; -----------------------------
1520
1521 .try_symbol:
1522         ; Should have the form
1523         ;
1524         ;   (try* A (catch* B C))
1525         ;
1526         ; where B is a symbol, A and C are forms to evaluate
1527
1528         ; Check first arg A
1529         mov al, BYTE [rsi + Cons.typecdr]
1530         cmp al, content_pointer
1531         jne .return_nil         ; No argument
1532
1533         mov rsi, [rsi + Cons.cdr]
1534
1535         ; Check if this is a value or pointer
1536         mov al, BYTE [rsi + Cons.typecar]
1537         and al, content_mask
1538         cmp al, content_pointer
1539         je .try_pointer
1540
1541         ; RSI contains a value. Copy and return
1542         mov cl, al
1543         call alloc_cons
1544         mov [rax], BYTE cl      ; Set type
1545         mov rbx, [rsi + Cons.car]
1546         mov [rax + Cons.car], rbx
1547         jmp .return
1548
1549 .try_pointer:
1550
1551         mov r8, [rsi + Cons.car]      ; form A in R8
1552
1553         ; Check second arg B
1554
1555         mov al, BYTE [rsi + Cons.typecdr]
1556         ; If nil (catchless try)
1557         cmp al, content_nil
1558         je .catchless_try
1559
1560         cmp al, content_pointer
1561         jne .try_missing_catch
1562
1563         mov rsi, [rsi + Cons.cdr]
1564
1565         mov al, BYTE [rsi]
1566         and al, content_mask
1567         cmp al, content_pointer
1568         jne .try_missing_catch
1569
1570         mov r9, [rsi + Cons.car] ; (catch* B C) in R9
1571
1572         mov al, BYTE [r9]
1573         cmp al, (container_list + content_pointer)
1574         jne .try_missing_catch
1575
1576         mov rsi, [r9 + Cons.car] ; Should be catch* symbol
1577         mov al, BYTE [rsi]
1578         cmp al, maltype_symbol
1579         jne .try_missing_catch
1580
1581         mov rdi, catch_symbol
1582         call compare_char_array
1583         test rax, rax           ; ZF set if rax = 0 (equal)
1584         jnz .try_missing_catch
1585
1586         ; Check that B is a symbol
1587         mov al, [r9 + Cons.typecdr]
1588         cmp al, content_pointer
1589         jne .catch_missing_symbol
1590
1591         mov r9, [r9 + Cons.cdr] ; (B C) in R9
1592
1593         mov al, BYTE [r9]
1594         and al, content_mask
1595         cmp al, content_pointer
1596         jne .catch_missing_symbol
1597
1598         mov r10, [r9 + Cons.car] ; B in R10
1599         mov al, BYTE [r10]
1600         cmp al, maltype_symbol
1601         jne .catch_missing_symbol
1602
1603         mov al, BYTE [r9 + Cons.typecdr]
1604         cmp al, content_pointer
1605         jne .catch_missing_form
1606         mov r9, [r9 + Cons.cdr] ; C in R9
1607
1608         ; Now have extracted from (try* A (catch* B C))
1609         ; A in R8
1610         ; B in R10
1611         ; C in R9
1612
1613         push R9
1614         push R10
1615         push r15                ; Env
1616
1617         ; Set the error handler
1618         mov rsi, rsp            ; Stack pointer
1619         mov rdi, .catch         ; Address to jump to
1620         xor rcx, rcx            ; No data
1621         call error_handler_push
1622
1623         ; Evaluate the form in R8
1624         mov rsi, r15
1625         call incref_object      ; Env released by eval
1626         mov rdi, r15            ; Env in RDI
1627
1628         mov rsi, r8             ; The form to evaluate (A)
1629
1630         call incref_object      ; AST released by eval
1631
1632         call eval
1633
1634         mov r8, rax             ; Result in R8
1635
1636         pop r15                 ; Environment
1637         ; Discard B and C
1638         ;add rsi, 8              ; pop R10 and R9
1639         pop r10
1640         pop r9
1641
1642         ; Remove error handler
1643         call error_handler_pop
1644         mov rax, r8
1645         jmp .return
1646
1647 .catchless_try:
1648         ;; Evaluate the form in R8
1649         push r15                ; Environment
1650
1651         mov rsi, r15
1652         call incref_object      ; Env released by eval
1653         mov rdi, r15            ; Env in RDI
1654
1655         mov rsi, r8             ; The form to evaluate (A)
1656
1657         call incref_object      ; AST released by eval
1658
1659         call eval               ; Result in RAX
1660
1661         pop r15                 ; Environment
1662
1663         jmp .return
1664 .catch:
1665         ; Jumps here on error
1666         ; Value thrown in RSI
1667         ;
1668
1669         push rsi
1670         call error_handler_pop
1671         pop rsi
1672
1673         pop r15                 ; Env
1674         pop r12                 ; B (symbol to bind)
1675         pop r13                 ; C (form to evaluate)
1676
1677         ; Check if C is a value or pointer
1678
1679         mov cl, BYTE [r13]
1680         and cl, content_mask
1681         cmp cl, content_pointer
1682         je .catch_C_pointer
1683
1684         ; A value, so copy and return
1685         call alloc_cons
1686         mov [rax], BYTE cl      ; Set type
1687         mov rbx, [r13 + Cons.car]
1688         mov [rax + Cons.car], rbx ; Set value
1689
1690         jmp .return
1691
1692 .catch_C_pointer:
1693
1694         mov r11, rsi            ; Value thrown in R11
1695
1696         mov rsi, r15            ; Outer env
1697         call env_new            ; Increments R15's ref count
1698
1699         mov rsi, rax            ; New environment in RSI
1700         mov rdi, r12            ; key (symbol)
1701         mov rcx, r11            ; value
1702         call env_set
1703
1704         mov rdi, rsi            ; Env in RDI (will be released)
1705         mov rsi, [r13 + Cons.car] ; Form to evaluate
1706         call incref_object      ; will be released
1707
1708         push r15
1709         call eval
1710         pop r15
1711
1712         jmp .return
1713
1714 .try_missing_catch:
1715         load_static try_missing_catch
1716         call raw_to_string
1717         mov rsi, rax
1718         jmp error_throw
1719
1720 .catch_missing_symbol:
1721         load_static catch_missing_symbol
1722         call raw_to_string
1723         mov rsi, rax
1724         jmp error_throw
1725
1726 .catch_missing_form:
1727         load_static catch_missing_form
1728         call raw_to_string
1729         mov rsi, rax
1730         jmp error_throw
1731
1732         ; -----------------------------
1733
1734 .list_eval:
1735         push rsi
1736         mov rdi, r15            ; Environment
1737         push r15
1738         call eval_ast           ; List of evaluated forms in RAX
1739         pop r15
1740         pop rsi
1741
1742 .list_exec:
1743         ; This point can be called to run a function
1744         ; used by swap!
1745         ;
1746         ; Inputs: RAX - List with function as first element
1747         ;               NOTE: This list is released
1748         ;
1749         ; Check that the first element of the return is a function
1750         mov bl, BYTE [rax]
1751         and bl, content_mask
1752         cmp bl, content_pointer
1753         jne .list_not_function
1754
1755         mov rbx, [rax + Cons.car] ; Get the address
1756         mov cl, BYTE [rbx]
1757         cmp cl, maltype_function
1758         jne .list_not_function
1759
1760         ; Check the rest of the args
1761         mov cl, BYTE [rax + Cons.typecdr]
1762         cmp cl, content_pointer
1763         je .list_got_args
1764
1765         ; No arguments
1766
1767         push rbx                ; Function object
1768
1769         mov rsi, rax            ; List with function first
1770         call release_object     ; Can be freed now
1771
1772         ; Create an empty list for the arguments
1773         call alloc_cons
1774         mov [rax], BYTE maltype_empty_list
1775
1776         pop rbx
1777         mov rsi, rax
1778         jmp  .list_function_call
1779 .list_got_args:
1780         mov rsi, [rax + Cons.cdr] ; Rest of list
1781 .list_function_call:
1782         ; Call the function with the rest of the list in RSI
1783
1784         mov rdx, rax            ; List to release
1785         mov rdi, rbx ; Function object in RDI
1786
1787         mov rbx, [rbx + Cons.car]   ; Call function
1788         cmp rbx, apply_fn
1789         je apply_fn_jmp             ; Jump to user function apply
1790
1791         ; A built-in function, so call (no recursion)
1792         push rax
1793         push r15
1794
1795         call rbx
1796
1797         ; Result in rax
1798         pop r15
1799         pop rsi                 ; eval'ed list
1800
1801         push rax
1802         call release_cons
1803         pop rax
1804         jmp .return             ; Releases Env
1805
1806 .list_not_function:
1807         ; Not a function. Probably an error
1808         push rsi
1809
1810         mov rsi, rax
1811         call release_object
1812
1813         print_str_mac error_string
1814         print_str_mac eval_list_not_function
1815         pop rsi
1816         jmp error_throw
1817
1818 .empty_list:
1819         mov rax, rsi
1820         jmp .return
1821
1822 ;; Applies a user-defined function
1823 ;;
1824 ;; Input: RSI - Arguments to bind
1825 ;;        RDI - Function object
1826 ;;        RDX - list to release after binding
1827 ;;        R15 - Env (will be released)
1828 ;;        R13 - AST released before return
1829 ;;
1830 ;;
1831 ;; Output: Result in RAX
1832 ;;
1833 ;; This is jumped to from eval, so if it returns
1834 ;; then it will return to the caller of eval, not to eval
1835 apply_fn_jmp:
1836         ; This is jumped to from eval with AST on the stack
1837         pop r13
1838 apply_fn:
1839         push rsi
1840         ; Extract values from the list in RDI
1841         mov rax, [rdi + Cons.cdr]
1842         mov rax, [rax + Cons.cdr] ; Meta (don't need)
1843         mov rsi, [rax + Cons.car] ; Env
1844         mov rax, [rax + Cons.cdr]
1845         mov rdi, [rax + Cons.car] ; Binds
1846         mov rax, [rax + Cons.cdr]
1847         mov rax, [rax + Cons.car] ; Body
1848         pop rcx                   ; Exprs
1849
1850         ; Check the type of the body
1851         mov bl, BYTE [rax]
1852         and bl, block_mask + container_mask
1853         jnz .bind
1854         ; Just a value (in RAX). No eval needed
1855
1856         mov r14, rax            ; Save return value in R14
1857
1858         mov rsi, rax
1859         call incref_object
1860
1861         ; Release the list passed in RDX
1862         mov rsi, rdx
1863         call release_object
1864
1865         ; Release the environment
1866         mov rsi, r15
1867         call release_object
1868
1869         ; Release the AST
1870         mov rsi, r13
1871         call release_object
1872
1873         mov rax, r14
1874         ret
1875 .bind:
1876         ; Create a new environment, binding arguments
1877         push rax                ; Body
1878
1879         mov r14, r13            ; Old AST. R13 used by env_new_bind
1880
1881         push rdx
1882         call env_new_bind
1883         pop rdx
1884
1885         mov rdi, rax       ; New environment in RDI
1886
1887         ; Note: Need to increment the reference count
1888         ; of the function body before releasing anything,
1889         ; since if the function was defined in-place (lambda)
1890         ; then the body may be released early
1891
1892         pop rsi            ; Body
1893         call incref_object ; Will be released by eval
1894         mov r8, rsi        ; Body in R8
1895
1896         ; Release the list passed in RDX
1897         mov rsi, rdx
1898         call release_cons
1899
1900         ; Release the environment
1901         mov rsi, r15
1902         call release_object
1903
1904         ; Release the old AST
1905         mov rsi, r14
1906         call release_object
1907
1908         mov rsi, r8             ; Body
1909
1910         jmp eval           ; Tail call
1911         ; The new environment (in RDI) will be released by eval
1912
1913
1914 ;; Set ZF if RSI is a non-empty list or vector
1915 ;; Modifies RAX, does not modify RSI
1916 is_pair:
1917         mov al, BYTE [rsi]
1918         test al, block_mask
1919         jnz .false              ; Not a Cons
1920         cmp al, maltype_empty_list
1921         je .false               ; Empty list
1922         cmp al, maltype_empty_vector
1923         je .false               ; Empty vector
1924
1925         ; Something non empty
1926         and al, container_mask
1927         cmp al, container_list
1928         je .true
1929         cmp al, container_vector
1930         je .true
1931         ; Not a list or vector -> false
1932
1933 .false:
1934         lahf                    ; flags in AH
1935         and ah, 255-64          ; clear zero flag
1936         sahf
1937         ret
1938 .true:
1939         lahf                    ; flags in AH
1940         or ah, 64               ; set zero flag
1941         sahf
1942         ret
1943
1944 ;; Called by eval with AST in RSI [ modified ]
1945 ;; Returns new AST in RAX
1946 quasiquote:
1947         ; i. Check if AST is an empty list
1948         call is_pair
1949         jne .quote_ast
1950
1951         ; ii. Check if the first element of RSI is the symbol
1952         ;     'unquote'
1953
1954         mov al, BYTE [rsi]
1955         and al, content_mask
1956         cmp al, content_pointer
1957         jne .not_unquote        ; Not a pointer
1958
1959         mov rdi, [rsi + Cons.car] ; Get the pointer
1960         mov cl, BYTE [rdi]
1961         cmp cl, maltype_symbol
1962         jne .not_unquote
1963
1964         ; Compare against 'unquote'
1965         mov r8, rsi
1966         mov r9, rax
1967
1968         mov rsi, unquote_symbol
1969         call compare_char_array
1970         test rax, rax
1971
1972         mov rax, r9
1973         mov rsi, r8
1974
1975         je .unquote
1976
1977 .not_unquote:
1978         ; iii. Handle splice-unquote
1979         ;      RSI -> ( ( splice-unquote ? ) ? )
1980
1981         ; Test if RSI contains a pointer
1982
1983         cmp al, content_pointer
1984         jne .not_splice
1985
1986         mov rbx, [rsi + Cons.car] ; Get the object pointer
1987
1988         ; RBX -> ( splice-unquote ? )
1989
1990         xchg rbx, rsi
1991         call is_pair
1992         xchg rbx, rsi
1993         jne .not_splice         ; First element not a pair
1994
1995         ; Check if this list in RBX starts with 'splice-unquote' symbol
1996         mov al, BYTE [rbx]
1997         and al, content_mask
1998         cmp al, content_pointer
1999         jne .not_splice
2000
2001
2002         mov rdi, [rbx + Cons.car] ; Get the pointer
2003         mov al, BYTE [rdi]
2004         cmp al, maltype_symbol
2005         jne .not_splice
2006
2007         mov r8, rsi
2008         mov r9, rbx
2009
2010         ; Compare against 'splice-unquote'
2011         mov rsi, splice_unquote_symbol
2012         call compare_char_array
2013         test rax, rax
2014
2015         mov rbx, r9
2016         mov rsi, r8
2017
2018         je .splice_unquote
2019
2020 .not_splice:
2021
2022         ; iv. Cons first and rest of AST in RSI
2023
2024         ; check if pointer or value
2025         mov cl, BYTE [rsi]
2026         and cl, content_mask
2027         cmp cl, content_pointer
2028         je .cons_pointer
2029
2030         ; a value, so copy
2031         call alloc_cons
2032         or cl, container_list
2033         mov [rax], BYTE cl      ; List + Content
2034         mov rbx, [rsi + Cons.car]
2035         mov [rax + Cons.car], rbx
2036         mov rcx, rax
2037         jmp .cons_first
2038
2039 .cons_pointer:
2040         ; Get the pointer and call quasiquote
2041         push rsi
2042         mov rsi, [rsi + Cons.car]
2043         call quasiquote
2044         mov rcx, rax
2045         pop rsi
2046
2047         call alloc_cons
2048         mov [rax], BYTE (container_list + content_pointer)
2049         mov [rax + Cons.car], rcx
2050         mov rcx, rax
2051
2052 .cons_first:
2053         ; Have Cons with first object in RCX
2054
2055         ; Call quasiquote on the rest of the AST
2056         ; Check if this is the end of the list
2057         mov al, BYTE [rsi + Cons.typecdr]
2058         cmp al, content_pointer
2059         jne .cons_ast_end
2060
2061         mov rsi, [rsi + Cons.cdr] ; Rest of the list
2062
2063         call incref_object      ; Will release after quasiquote call
2064
2065         jmp .cons_quasiquote_ast
2066
2067 .cons_ast_end:
2068         ; End of the AST, so make an empty list
2069         call alloc_cons
2070         mov [rax], BYTE maltype_empty_list
2071         mov rsi, rax
2072
2073 .cons_quasiquote_ast:
2074         push rcx
2075         push rsi
2076         call quasiquote
2077         mov rdx, rax            ; List in RDX
2078
2079         pop rsi
2080         call release_object     ; Release input
2081
2082         pop rcx                 ; Value in RCX
2083
2084         ; cons RCX and RDX
2085         ; Work from the end of the list to the front
2086
2087         call alloc_cons
2088         mov [rax], BYTE (container_list + content_pointer)
2089         mov [rax + Cons.car], rdx ; The rest of AST
2090
2091         ; Link to the RCX Cons
2092         mov [rcx + Cons.typecdr], BYTE content_pointer
2093         mov [rcx + Cons.cdr], rax
2094         mov rdx, rcx
2095
2096         call alloc_cons         ; Cons for cons symbol
2097         mov [rax + Cons.typecdr], BYTE content_pointer
2098         mov [rax + Cons.cdr], rdx
2099         mov rdx, rax
2100
2101         ; Get the cons symbol
2102         mov rsi, cons_symbol
2103         call incref_object
2104
2105         mov [rdx], BYTE (container_list + content_pointer)
2106         mov [rdx + Cons.car], rsi
2107
2108         mov rax, rdx
2109         ret
2110
2111 .quote_ast:
2112         ; Return (quote RSI)
2113
2114         call incref_object      ; RSI reference count
2115
2116         ; Cons for RSI
2117         call alloc_cons
2118         mov [rax], BYTE (block_cons + container_list + content_pointer)
2119         mov [rax + Cons.car], rsi
2120         mov rsi, rax
2121
2122         ; Cons for quote symbol
2123         call alloc_cons
2124         mov rbx, rax
2125         mov [rbx + Cons.typecdr], BYTE content_pointer
2126         mov [rbx + Cons.cdr], rsi
2127
2128         ; Get a quote symbol, incrementing references
2129         mov rsi, quote_symbol
2130         call incref_object
2131
2132         ; Put into the Cons in RBX
2133         mov [rbx + Cons.car], rsi
2134         mov [rbx], BYTE (block_cons + container_list + content_pointer)
2135         mov rax, rbx
2136         ret
2137         ; -----------------------
2138
2139 .unquote:
2140
2141         ; Got unquote symbol. Return second element of RSI
2142         mov al, BYTE [rsi + Cons.typecdr]
2143         cmp al, content_pointer
2144         jne .empty_list              ; No second element
2145
2146         mov rsi, [rsi + Cons.cdr]
2147
2148         ; Check if it's a value or pointer
2149         mov cl, BYTE [rsi]
2150         and cl, content_mask
2151         cmp cl, content_pointer
2152         je .unquote_pointer
2153
2154         ; A value, so need a new Cons
2155         call alloc_cons
2156         mov [rax], BYTE cl      ; content
2157         mov rbx, [rsi + Cons.car]
2158         mov [rax + Cons.car], rbx ; Copy content
2159         ret
2160
2161 .unquote_pointer:
2162         mov rsi, [rsi + Cons.car]
2163         call incref_object
2164         mov rax, rsi
2165         ret
2166
2167         ; -----------------------
2168 .splice_unquote:
2169         ; RSI -> ( RBX->( splice-unquote A ) B )
2170         ;
2171         ; RBX Car points to splice-unquote symbol
2172
2173         ; Check if there is anything after the symbol
2174         mov al, BYTE [rbx + Cons.typecdr]
2175         cmp al, content_pointer
2176         jne .splice_unquote_empty
2177
2178         ; Point to the second element of the splice-unquote list
2179         mov rcx, [rbx + Cons.cdr]
2180
2181         ; Check whether it's a value or pointer
2182         mov al, BYTE [rcx]
2183         and al, content_mask
2184         cmp al, content_pointer
2185         je .splice_unquote_pointer
2186
2187         ; A value, so change the container to a value
2188         mov [rcx], BYTE al
2189         ; Remove pointer from RBX
2190         mov [rbx + Cons.typecdr], BYTE 0
2191         jmp .splice_unquote_first ; Got the value in RCX
2192
2193 .splice_unquote_pointer:
2194         mov rcx, [rcx + Cons.car] ; Get the object pointed to
2195         xchg rcx, rsi
2196         call incref_object
2197         xchg rcx, rsi           ; Object in RCX
2198
2199 .splice_unquote_first:          ; Got the first object in RCX
2200
2201         ; Check if RSI contains anything else
2202         mov al, BYTE [rsi + Cons.typecdr]
2203         cmp al, content_pointer
2204         jne .splice_unquote_notail
2205
2206         mov rsi, [rsi + Cons.cdr]
2207
2208         ; Now have:
2209         ; ( ( splice-unquote A ) B )
2210         ; RCX->A RSI->( B )
2211         ; Need to call quasiquote on the rest of the list
2212         push rcx
2213         call quasiquote
2214         mov rdx, rax
2215         pop rcx
2216         ; Need to concat rcx and rdx
2217         ; Work from the end of the list to the front
2218
2219         call alloc_cons
2220         mov [rax], BYTE (container_list + content_pointer)
2221         mov [rax + Cons.car], rdx ; The rest of AST
2222         mov rdx, rax              ; Push list into RDX
2223
2224         call alloc_cons
2225         mov [rax], BYTE (container_list + content_pointer)
2226         mov [rax + Cons.car], rcx ; The splice-unquote object
2227         mov [rax + Cons.typecdr], BYTE content_pointer
2228         mov [rax + Cons.cdr], rdx
2229         mov rdx, rax
2230
2231         call alloc_cons         ; Cons for concat symbol
2232         mov [rax + Cons.typecdr], BYTE content_pointer
2233         mov [rax + Cons.cdr], rdx
2234         mov rdx, rax
2235
2236         ; Get the concat symbol
2237         mov rsi, concat_symbol
2238         call incref_object
2239
2240         mov [rdx], BYTE (container_list + content_pointer)
2241         mov [rdx + Cons.car], rsi
2242
2243         mov rax, rdx
2244         ret
2245
2246 .splice_unquote_notail:
2247         ; Just return the object in RCX
2248         ; since nothing to concatenate with
2249         mov rax, rcx
2250         ret
2251
2252 .splice_unquote_empty:
2253         ; Nothing in the (splice-unquote) list, so ignore
2254         ; Just call quasiquote on the rest of RSI
2255
2256         mov al, BYTE [rsi + Cons.typecdr]
2257         cmp al, content_pointer
2258         jne .empty_list         ; Nothing else
2259
2260         mov rsi, [rsi + Cons.cdr]
2261         jmp quasiquote          ; Tail call
2262
2263 .empty_list:
2264         ; Return an empty list
2265         call alloc_cons
2266         mov [rax], BYTE maltype_empty_list
2267 .return:
2268         ret
2269
2270
2271 ;; Tests if an AST in RSI is a list containing
2272 ;; a macro defined in the ENV in R15
2273 ;;
2274 ;; Inputs: AST in RSI (not modified)
2275 ;;         ENV in R15 (not modified)
2276 ;;
2277 ;; Returns: Sets ZF if macro call. If set (true),
2278 ;;          then the macro object is in RAX
2279 ;;
2280 ;; Modifies:
2281 ;;    RAX
2282 ;;    RBX
2283 ;;    RCX
2284 ;;    RDX
2285 ;;    R8
2286 ;;    R9
2287 is_macro_call:
2288         ; Test if RSI is a list which contains a pointer
2289         mov al, BYTE [rsi]
2290         cmp al, (block_cons + container_list + content_pointer)
2291         jne .false
2292
2293         ; Test if this is a symbol
2294         mov rbx, [rsi + Cons.car]
2295         mov al, BYTE [rbx]
2296         cmp al, maltype_symbol
2297         jne .false
2298
2299         ; Look up symbol in Env
2300         push rsi
2301         push r15
2302         mov rdi, rbx            ; symbol in RDI
2303         mov rsi, r15            ; Environment in RSI
2304         call env_get
2305         pop r15
2306         pop rsi
2307         jne .false              ; Not in environment
2308
2309         ; Object in RAX
2310         ; If this is not a macro then needs to be released
2311         mov dl, BYTE [rax]
2312
2313         cmp dl, maltype_macro
2314         je .true
2315
2316         ; Not a macro, so release
2317         mov r8, rsi
2318         mov rsi, rax
2319         call release_object
2320         mov rsi, r8
2321
2322 .false:
2323         lahf                    ; flags in AH
2324         and ah, 255-64          ; clear zero flag
2325         sahf
2326         ret
2327 .true:
2328         mov rbx, rax            ; Returning Macro object
2329         lahf                    ; flags in AH
2330         or ah, 64               ; set zero flag
2331         sahf
2332         mov rax, rbx
2333         ret
2334
2335 ;; Expands macro calls
2336 ;;
2337 ;; Input: AST in RSI (released and replaced)
2338 ;;        Env in R15 (not modified)
2339 ;;
2340 ;; Result: New AST in RSI
2341 macroexpand:
2342         push r15
2343
2344         call is_macro_call
2345         jne .done
2346
2347         mov r13, rsi
2348
2349         mov rdi, rax  ; Macro in RDI
2350
2351         ; Check the rest of the args
2352         mov cl, BYTE [rsi + Cons.typecdr]
2353         cmp cl, content_pointer
2354         je .got_args
2355
2356         ; No arguments. Create an empty list
2357         call alloc_cons
2358         mov [rax], BYTE maltype_empty_list
2359         mov rdx, rax
2360
2361         mov rsi, rdx            ; Arguments (empty list)
2362         call incref_object
2363         jmp .macro_call
2364 .got_args:
2365         mov rsi, [rsi + Cons.cdr] ; Rest of list
2366         call incref_object
2367         mov rdx, rsi            ; Released
2368 .macro_call:
2369         ; Here have:
2370         ;   RSI - Arguments
2371         ;   RDI - Macro object
2372         ;   RDX - List to release
2373         ;   R15 - Environment
2374         ;   R13 - AST
2375
2376         ; Increment reference for Environment
2377         ; since this will be released by apply_fn
2378         xchg rsi, r15
2379         call incref_object
2380         xchg rsi, r15
2381
2382         call apply_fn
2383
2384         mov rsi, rax ; Result in RSI
2385
2386         pop r15
2387         jmp macroexpand
2388 .done:
2389         pop r15
2390         ret
2391
2392 ;; Read and eval
2393 read_eval:
2394         ; -------------
2395         ; Read
2396         call read_str
2397
2398         ; -------------
2399         ; Eval
2400         mov rsi, rax            ; Form to evaluate
2401         mov rdi, [repl_env]     ; Environment
2402
2403         xchg rsi, rdi
2404         call incref_object      ; Environment increment refs
2405         xchg rsi, rdi           ; since it will be decremented by eval
2406
2407         jmp eval               ; This releases Env and Form/AST
2408
2409
2410 ;; Read-Eval-Print in sequence
2411 ;;
2412 ;; Input string in RSI
2413 rep_seq:
2414         ; -------------
2415         ; Read
2416         call read_str
2417
2418         ; -------------
2419         ; Eval
2420         mov rsi, rax            ; Form to evaluate
2421         mov rdi, [repl_env]     ; Environment
2422
2423         xchg rsi, rdi
2424         call incref_object      ; Environment increment refs
2425         xchg rsi, rdi           ; since it will be decremented by eval
2426
2427         call eval               ; This releases Env and Form/AST
2428         push rax                ; Save result of eval
2429
2430         ; -------------
2431         ; Print
2432
2433         mov rsi, rax            ; Output of eval into input of print
2434         mov rdi, 1              ; print readably
2435         call pr_str             ; String in RAX
2436
2437         mov r8, rax             ; Save output
2438
2439         pop rsi                 ; Result from eval
2440         call release_object
2441         mov rax, r8
2442
2443         ret
2444
2445
2446 _start:
2447         ; Create and print the core environment
2448         call core_environment   ; Environment in RAX
2449
2450         mov [repl_env], rax     ; store in memory
2451
2452         ; Set the error handler
2453         mov rsi, rsp            ; Stack pointer
2454         mov rdi, .catch         ; Address to jump to
2455         xor rcx, rcx            ; No data
2456         call error_handler_push
2457
2458         ; Evaluate the startup string
2459
2460         mov rsi, mal_startup_string
2461         mov edx, mal_startup_string.len
2462         call raw_to_string      ; String in RAX
2463
2464         push rax
2465         mov rsi, rax
2466         call read_str           ; AST in RAX
2467         pop rsi                 ; string
2468
2469         push rax                ; AST
2470         call release_array      ; string
2471         pop rdi                 ; AST in RDI
2472
2473         mov rsi, [repl_env]     ; Environment in RSI
2474
2475         call incref_object      ; Environment increment refs
2476         xchg rsi, rdi           ; Env in RDI, AST in RSI
2477
2478         call eval
2479
2480         mov rsi, rax
2481         call release_object     ; Return from eval
2482
2483         ; -----------------------------
2484         ; Check command-line arguments
2485
2486         pop rax                 ; Number of arguments
2487         cmp rax, 1              ; Always have at least one, the path to executable
2488         jg run_script
2489
2490         ; No extra arguments, so just set *ARGV* to an empty list
2491         call alloc_cons         ; in RAX
2492         mov [rax], BYTE maltype_empty_list
2493         mov rcx, rax            ; value (empty list)
2494         mov rdi, argv_symbol    ; symbol (*ARGV*)
2495         mov rsi, [repl_env]     ; environment
2496         call env_set
2497
2498         ; -----------------------------
2499         ; Header
2500
2501         load_static mal_startup_header
2502         call raw_to_string
2503         push rax
2504
2505         mov rsi, rax
2506         call read_eval          ; no print ('nil')
2507         mov rsi, rax
2508         call release_object     ; Release result of eval
2509
2510         ; Release the input string
2511         pop rsi
2512         call release_array
2513
2514         ; -----------------------------
2515         ; Main loop
2516
2517 .mainLoop:
2518         ; print the prompt
2519         print_str_mac prompt_string
2520
2521         call read_line
2522
2523         ; Check if we have a zero-length string
2524         cmp DWORD [rax+Array.length], 0
2525         je .mainLoopEnd
2526
2527         push rax                ; Save address of the string
2528
2529         mov rsi, rax
2530         call rep_seq            ; Read-Eval-Print
2531
2532         push rax                ; Save returned string
2533
2534         mov rsi, rax            ; Put into input of print_string
2535         call print_string
2536
2537         ; Release string from rep_seq
2538         pop rsi
2539         call release_array
2540
2541         ; Release the input string
2542         pop rsi
2543         call release_array
2544
2545         jmp .mainLoop
2546 .mainLoopEnd:
2547
2548         jmp quit
2549
2550 .catch:
2551         ; Jumps here on error
2552
2553         ; Check if an object was thrown
2554         cmp rsi, 0
2555         je .catch_done_print                ; nothing to print
2556
2557         push rsi
2558         print_str_mac error_string   ; print 'Error: '
2559         pop rsi
2560
2561         mov rdi, 1
2562         call pr_str
2563         mov rsi, rax
2564         call print_string
2565 .catch_done_print:
2566         jmp .mainLoop           ; Go back to the prompt
2567
2568
2569
2570 run_script:
2571         ; Called with number of command-line arguments in RAX
2572         mov r8, rax
2573         pop rbx                 ; executable
2574         dec r8
2575
2576         pop rsi                  ; Address of first arg
2577         call cstring_to_string   ; string in RAX
2578         mov r9, rax
2579
2580         ; get the rest of the args
2581         xor r10, r10            ; Zero
2582         dec r8
2583         jz .no_args
2584
2585         ; Got some arguments
2586 .arg_loop:
2587         ; Got an argument left.
2588         pop rsi                 ; Address of C string
2589         call cstring_to_string  ; String in RAX
2590         mov r12, rax
2591
2592         ;Make a Cons to point to the string
2593         call alloc_cons         ; in RAX
2594         mov [rax], BYTE (block_cons + container_list + content_pointer)
2595         mov [rax + Cons.car], r12
2596
2597         test r10, r10
2598         jnz .append
2599
2600         ; R10 zero, so first arg
2601         mov r10, rax            ; Head of list
2602         mov r11, rax            ; Tail of list
2603         jmp .next
2604 .append:
2605         ; R10 not zero, so append to list tail
2606         mov [r11 + Cons.cdr], rax
2607         mov [r11 + Cons.typecdr], BYTE content_pointer
2608         mov r11, rax
2609 .next:
2610         dec r8
2611         jnz .arg_loop
2612         jmp .got_args
2613
2614 .no_args:
2615         ; No arguments. Create an emoty list
2616         call alloc_cons         ; in RAX
2617         mov [rax], BYTE maltype_empty_list
2618         mov r10, rax
2619
2620 .got_args:
2621         push r9                 ; File name string
2622
2623         mov rcx, r10            ; value (list)
2624         mov rdi, argv_symbol    ; symbol (*ARGV*)
2625         mov rsi, [repl_env]     ; environment
2626         call env_set
2627
2628         mov rsi, run_script_string ; load-file function
2629         mov edx, run_script_string.len
2630         call raw_to_string      ; String in RAX
2631
2632         mov rsi, rax
2633         pop rdx                 ; File name string
2634         call string_append_string
2635
2636         mov cl, 34              ; "
2637         call string_append_char
2638         mov cl, ')'
2639         call string_append_char ; closing brace
2640
2641         ; Read-Eval "(load-file <file>)"
2642         call read_eval
2643
2644         jmp quit