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