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