nasm/step7_quote.asm

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