impc:ir:compiler:array-set   scheme

(define impc:ir:compiler:array-set
  (lambda (ast types)
    (let* ((os (make-string 0))
           (index-str (impc:ir:compiler (caddr ast) types))
           (idx (impc:ir:gname))
           (var-str (impc:ir:compiler (cadr ast) types))
           (var (impc:ir:gname))
           (ttype (impc:ir:get-type-from-str (cadr var)))
           (val-str (impc:ir:compiler (cadddr ast) types
                                      (if (impc:ir:array? ttype)
                                          (caddr ttype)
                                          (impc:ir:pointer-- (cadr var)))))
           (val (impc:ir:gname)))
      ;; type tests
      (if (not (impc:ir:array? ttype))
          (impc:compiler:print-bad-type-error-with-ast (cadr var) "invalid array type" ast))
      (if (> (impc:ir:get-ptr-depth ttype) 1)
          (impc:compiler:print-compiler-error "pointer depth too great for aset!" ast))
      (if (not (impc:ir:fixed-point? (impc:ir:get-type-from-str (cadr idx))))
          (impc:compiler:print-bad-type-error-with-ast (cadr idx) "index must be an integer" ast))
      (if (not (equal? (impc:ir:get-type-from-str (cadr val)) ;(impc:ir:get-type-from-str (cadr var))
                       (if (impc:ir:array? ttype)
                           (caddr ttype)
                           (impc:ir:pointer-- (impc:ir:get-type-from-str (cadr var))))))
          (impc:compiler:print-type-mismatch-error (cadr val) (cadr var) (car ast)))
      (if (and (integer? (caddr ast)) (> (+ 1 (caddr ast)) (cadr ttype)))
          (impc:compiler:print-index-oob-error 'array ast))
      ;; type tests done
      (emit index-str os)
      (emit var-str os)
      (emit val-str os)
      (emit "; set array\n" os)
      (if (not (impc:ir:pointer? ttype)) ;; must be an array if we're not a pointer
          (impc:compiler:print-bad-type-error-with-ast (cadr ttype) "aset! must take a pointer to an array" ast)
                                        ;(begin (emit (impc:ir:gname "val" (impc:ir:get-type-str (caddr ttype))) " = insertvalue "
                                        ;     (cadr var) " " (car var) ", " (cadr val) " " (car val) ", " (car idx) "\n" os))
          (begin (emit (impc:ir:gname "val" (string-append (impc:ir:get-type-str (caddr ttype)) "*"))
                       " = getelementptr " (impc:ir:pointer-- (cadr var)) ", " (cadr var) " " (car var)
                       ", i32 0, " (cadr idx) " " (car idx) "\n" os)
                 (emit "store " (cadr val) " " (car val) ", "
                       (cadr (impc:ir:gname)) " " (car (impc:ir:gname)) "\n" os)))
      (impc:ir:gname "val" (car val) (cadr val))
      (impc:ir:strip-space os))))