nasm/env.asm

   1
   2 %include "macros.mac"
   3
   4 ;; ------------------------------------------------------------
   5 ;; Environment type
   6 ;;
   7 ;; These are lists of maps. The head of the list is the
   8 ;; current environment, and CDR points to the outer environment
   9 ;;
  10 ;; ( {} {} ... )
  11
  12 section .data
  13
  14 ;; Symbols used for comparison
  15         static_symbol env_symbol, '*env*'
  16
  17 ;; Error message strings
  18
  19         static env_binds_error_string, db "Expecting symbol in binds list",10
  20         static env_binds_missing_string, db "Missing expression in bind",10
  21
  22 section .text
  23
  24 ;; Create a new Environment
  25 ;;
  26 ;; Input: outer Environment in RSI.
  27 ;;         - If zero, then nil outer.
  28 ;;         - If not zero, increments reference count
  29 ;;
  30 ;; Return a new Environment type in RAX
  31 ;;
  32 ;; Modifies registers:
  33 ;;   RAX
  34 ;;   RBX
  35 env_new:
  36         call map_new            ; map in RAX
  37         push rax
  38         call alloc_cons         ; Cons in RAX
  39         pop rbx                 ; map in RBX
  40
  41         mov [rax], BYTE (block_cons + container_list + content_pointer)
  42         ; CDR type already set to nil in alloc_cons
  43         mov [rax + Cons.car], rbx
  44
  45         cmp rsi, 0
  46         jne .set_outer
  47         ret                     ; No outer, just return
  48 .set_outer:
  49         mov [rax + Cons.typecdr], BYTE content_pointer
  50         mov [rax + Cons.cdr], rsi
  51
  52         ; increment reference counter of outer
  53         mov rbx, rax            ; because incref_object modifies rax
  54         call incref_object
  55         mov rax, rbx
  56         ret
  57
  58 ;; Create a new environment using a binding list
  59 ;;
  60 ;; Input: RSI - Outer environment
  61 ;;        RDI - Binds, a list of symbols
  62 ;;        RCX - Exprs, a list of values to bind each symbol to
  63 ;;
  64 ;; Modifies registers
  65 ;;    RBX
  66 ;;    R8
  67 ;;    R9
  68 ;;    R10
  69 ;;    R11
  70 ;;    R12
  71 ;;    R13
  72 env_new_bind:
  73         mov r11, rdi            ; binds list in R11
  74         mov r12, rcx            ; expr list in R12
  75
  76         call env_new
  77         mov r13, rax             ; New environment in R13
  78
  79 .bind_loop:
  80         ; Check the type in the bind list
  81         mov bl, BYTE [r11]
  82         and bl, content_mask
  83         cmp bl, content_empty
  84         je .done                ; No bindings
  85
  86         cmp bl, content_pointer
  87         jne .bind_not_symbol
  88
  89         mov rdi, [r11 + Cons.car] ; Symbol object?
  90         mov bl, BYTE [rdi]
  91         cmp bl, maltype_symbol
  92         jne .bind_not_symbol
  93
  94         ; RDI now contains a symbol
  95         ; Check the type in expr
  96
  97         mov bl, BYTE [r12]
  98         mov bh, bl
  99         and bh, content_mask
 100         cmp bh, content_pointer
 101         je .value_pointer
 102
 103         ; A value. Need to remove the container type
 104         xchg bl,bh
 105         mov [r12], BYTE bl
 106         xchg bl,bh
 107         mov rcx, r12            ; Value
 108         mov rsi, r13            ; Env
 109         push rbx
 110         call env_set
 111         pop rbx
 112         ; Restore original type
 113         mov [r12], BYTE bl
 114         jmp .next
 115
 116 .value_pointer:
 117         ; A pointer to something, so just pass address to env_set
 118         mov rcx, [r12 + Cons.car]
 119         mov rsi, r13
 120         call env_set
 121         ; Fall through to next
 122 .next:
 123         ; Check if there is a next
 124         mov bl, BYTE [r11 + Cons.typecdr]
 125         cmp bl, content_pointer
 126         jne .done
 127
 128         ; Got another symbol
 129         mov r11, [r11 + Cons.cdr] ; Next symbol
 130
 131         ; Check if there's an expression to bind to
 132         mov bl, BYTE [r12 + Cons.typecdr]
 133         cmp bl, content_pointer
 134         jne .bind_missing_expr
 135
 136         mov r12, [r12 + Cons.cdr] ; Next expression
 137         jmp .bind_loop
 138 .done:
 139         mov rax, r13            ; Env
 140         ret
 141
 142 .bind_not_symbol:               ; Expecting a symbol
 143         push r11                ; Binds list
 144
 145         ; Release the environment
 146         mov rsi, r13
 147         call release_object
 148
 149         print_str_mac error_string   ; print 'Error: '
 150
 151         print_str_mac env_binds_error_string
 152
 153         pop rsi                 ; Throw binds list
 154         jmp error_throw
 155
 156 .bind_missing_expr:
 157         push r11                ; Binds list
 158
 159         ; Release the environment
 160         mov rsi, r13
 161         call release_object
 162
 163         print_str_mac error_string   ; print 'Error: '
 164
 165         print_str_mac env_binds_missing_string
 166
 167         pop rsi                 ; Throw binds list
 168         jmp error_throw
 169
 170
 171 ;; Environment set
 172 ;;
 173 ;; Sets a key-value pair in an environment
 174 ;;
 175 ;; Inputs: RSI - env [not modified]
 176 ;;         RDI - key [not modified]
 177 ;;         RCX - value [not modified]
 178 ;;
 179 ;; Increments reference counts of key and value
 180 ;; if pointers to them are created
 181 ;;
 182 ;; Modifies registers:
 183 ;;   R8
 184 ;;   R9
 185 ;;   R10
 186 env_set:
 187         push rsi
 188         ; Get the first CAR, which should be a map
 189         mov rsi, [rsi + Cons.car]
 190         call map_set
 191         pop rsi
 192         ret
 193
 194 ;; Environment get
 195 ;;
 196 ;; Get a value from an environment, incrementing the reference count
 197 ;; of the object returned
 198 ;;
 199 ;; Inputs: RSI - environment
 200 ;;         RDI - key
 201 ;;
 202 ;; Returns: If found, Zero Flag is set and address in RAX
 203 ;;          If not found, Zero Flag cleared
 204 env_get:
 205         push rsi
 206
 207         ; Check special variable *env*
 208         mov rsi, env_symbol
 209         call compare_char_array
 210         pop rsi
 211         cmp rax, 0
 212         jne .not_env_symbol
 213
 214         ; Env symbol, so return this environment
 215         call incref_object
 216         lahf                    ; flags in AH
 217         or ah, 64          ; set zero flag
 218         sahf
 219         mov rax, rsi
 220         ret
 221
 222 .not_env_symbol:
 223         push rsi
 224         ; Get the map in CAR
 225         mov rsi, [rsi + Cons.car]
 226         call map_get
 227         pop rsi
 228         je .found
 229
 230         ; Not found, so try outer
 231
 232         mov al, BYTE [rsi + Cons.typecdr]
 233         cmp al, content_pointer
 234         jne .not_found
 235
 236         mov rsi, [rsi + Cons.cdr] ; outer
 237         jmp env_get
 238 .found:
 239         ret
 240
 241 .not_found:
 242         lahf                    ; flags in AH
 243         and ah, 255-64          ; clear zero flag
 244         sahf
 245         ret
 246
 247