path: root/module/c/eval.scm

(define-module (c eval)
  :use-module (hnh util)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-71)
  :use-module (srfi srfi-88)
  :use-module (ice-9 match)
  :use-module (ice-9 curried-definitions)
  :use-module ((rnrs bytevectors)
               :select (bytevector?))
  :use-module ((rnrs arithmetic bitwise)
               :select (bitwise-not
                        bitwise-and
                        bitwise-ior
                        bitwise-xor
                        bitwise-arithmetic-shift-left
                        bitwise-arithmetic-shift-right))
  :use-module (c eval environment)
  :export (c-procedure?
           procedure-formals
           procedure-body
           procedure-arity

           c-eval
           ))

(define C-TRUE 1)
(define C-FALSE 0)

(define (boolean->c-boolean bool)
  (if bool C-TRUE C-FALSE))

(define (c-boolean->boolean bool)
  (not (zero? bool)))

(define (c-not b)
  (-> b c-boolean->boolean not boolean->c-boolean))

(define (c-procedure? expr)
  (and (list? expr)
       (not (null? expr))
       (eq? 'lambda (car expr))))

(define* (ensure-c-procedure expr optional: calling-procedure)
  (unless (c-procedure? expr)
    (scm-error 'c-eval-error calling-procedure
               "Value not a procedure: ~s"
               (list procedure #f))))

(define (procedure-formals procedure)
  (ensure-c-procedure procedure "procedure-formals")
  (list-ref procedure 1))

(define (procedure-body procedure)
  (ensure-c-procedure procedure "procedure-body")
  (list-ref procedure 2))

(define (procedure-arity procedure)
  (length (procedure-formals procedure)))

(define (literal? expression)
  (or (number? expression)
      (bytevector? expression)))



;; Internal helper procedures

(define (mod-set operation)
  (lambda (env slot value)
    ;; a += b
    ;; a = a + b
    (c-eval env `(= ,slot (,operation ,slot ,value)))))

(define (fold-2 proc init lst)
  (car+cdr
   (fold (lambda (arg env+done)
           (let ((env* arg* (proc (car env+done) arg)))
             (cons* env* arg* (cdr env+done))))
         init
         lst)))

;; TODO this disregards
;; - floating point convertions
;; - integer truncation
(define ((simple-infix operation) env . operands)
  (let ((env done (fold-2 c-eval (cons env '()) operands)))
    (values env (apply operation (reverse done)))))

(define ((binary-operator proc) env i c)
  (let ((env* i* (c-eval env i)))
    (let ((env** c* (c-eval env* c)))
      (values env** (proc i* c*)))))




;; The order of evaluation for a number of these is undefined, meaning
;; that any side effects without sequence points is undefined.
;; However, for many of these I do the sensible thing and evaluate them
;; from left to right, instead of ignoring all side effects.

;; TODO double check these with a C standard


;; Operators have their own namespace. They are called without funcall
;; in the pseudo-lisp which C is compiled to, and they expand more like
;; lisp macros, since its up to each operator what to do with its operands.
;; This to allow assignment and short circuting.
(define primitives
  `((and . ,(lambda (env . operands)
              (let loop ((env env) (operands operands))
                (if (null? operands)
                    (values env C-TRUE)
                    (let* ((env* result (c-eval env (car operands))))
                      (if (c-boolean->boolean result)
                          (loop env* (cdr operands))
                          (values env* result)))))))
    (or . ,(lambda (env . operands)
             (let loop ((env env) (operands operands))
               (if (null? operands)
                   (values env C-FALSE)
                   (let* ((env* result (c-eval env (car operands))))
                     (if (false? result)
                         (values env* result)
                         (loop env* (cdr operands))))))))
    (= . ,(lambda (env slot value)
            ;; TOOD if slot isn't a variable, but a field (or array index)
            ;; then it needs to be resolved...
            (let ((env* result (c-eval env value)))
              (values (env-set! env* slot result)
                      result))))
    (and_eq ,(mod-set 'bitand))         ; &=
    (or_eq  ,(mod-set 'bitor))          ; |=
    (xor_eq ,(mod-set 'xor))            ; ^=
    (+=  ,(mod-set '+))
    (-=  ,(mod-set '-))
    (*=  ,(mod-set '*))
    (/=  ,(mod-set '/))
    (<<= ,(mod-set '<<))
    (>>= ,(mod-set '>>))
    (%=  ,(mod-set '%))
    (+ . ,(simple-infix +))
    (* . ,(simple-infix *))
    (/ . ,(simple-infix /))
    (- . ,(lambda (env op . operands)
            (if (null? operands)
                (let ((env* value (c-eval env op)))
                  (values env* (- value)))
                (apply (simple-infix -)
                       env op operands))))
    (bitor  . ,(simple-infix bitwise-ior))
    (bitand . ,(simple-infix bitwise-and))
    (xor    . ,(simple-infix bitwise-xor))
    (not_eq . ,(lambda (env a b) (c-eval env `(not (== ,a ,b))))) ; !=
    (<< . ,(binary-operator bitwise-arithmetic-shift-left))
    (>> . ,(binary-operator bitwise-arithmetic-shift-right))
    (< . ,(binary-operator (compose boolean->c-boolean <)))
    (> . ,(binary-operator (compose boolean->c-boolean >)))
    ;; this assumes that = handles pointers
    (== . ,(binary-operator (compose boolean->c-boolean =)))
    (<= . ,(binary-operator (compose boolean->c-boolean <=)))
    (>= . ,(binary-operator (compose boolean->c-boolean >=)))
    (% .  ,(binary-operator modulo))

    (not . ,(lambda (env value)
              (let ((env* result (c-eval env value)))
                (values env* (c-not result)))))
    (compl . ,(lambda (env value)
                (let ((env* result (c-eval env value)))
                  (values env* (bitwise-not result)))))

    ;; ++C
    (pre-increment . ,(lambda (env slot) (c-eval env `(+= ,slot 1))))
    (pre-decrement . ,(lambda (env slot) (c-eval env `(-= ,slot 1))))
    ;; TODO these (C++, C--) need to handle if slot isn't a direct variabl
    (post-increment . ,(lambda (env slot)
                         (let ((value (env-ref env slot)))
                           (values (env-set! env slot (1+ value))
                                   value))))
    (pre-decrement . ,(lambda (env slot)
                        (let ((value (env-ref env slot)))
                          (values (env-set! env slot (1+ value))
                                  value))))

    (ternary . ,(lambda (env test true-clause false-clause)
                  (let ((env* value (c-eval env test)))
                    (c-eval env*
                            (if (c-boolean->boolean value)
                                true-clause false-clause)))))

    ;; TODO remaining operations
    (as-type . ,(lambda (env target-type value)
                  (format (current-error-port) "cast<~s>(~s)~%" target-type value)
                  (values env value)))

    (object-slot . ,(lambda (env object slot)
                      (scm-error 'not-implemented "object-slot"
                                 "Object slots are not implemented, when accessing ~s.~s"
                                 (list object slot) #f)))
    (dereference-slot ,(lambda (env ptr slot)
                          (scm-error 'not-implemented "dereference-slot"
                                 "Object slots are not implemented, when accessing ~s->~s"
                                 (list object slot) #f)))
    (dereference . ,(lambda (env ptr)
                      (scm-error 'not-implemented "dereference"
                                 "Poiner dereferencing is not implemented: *~s"
                                 (list ptr) #f)))
    (pointer . ,(lambda (env value)
                  (scm-error 'not-implemented "pointer"
                             "Pointer of is not implemented: &~s"
                             (list value) #f)))))

;; TODO |,|


(define (c-eval environment expression)
  (match expression
    (('lambda formals body) (values environment `(lambda ,formals ,body)))
    ;; hack since sizeof really should be a operator
    (('funcall 'sizeof arg)
     ;; TODO
     (format (current-error-port) "sizeof ~s~%" arg)
     (values environment 1))

    (('funcall procedure-name ('#{,}# args ...))
     (let ((procedure (env-ref environment procedure-name)))
       (ensure-c-procedure procedure "c-eval")
       (unless (= (length args) (procedure-arity procedure))
         (scm-error 'c-eval-error "c-eval"
                    "Procedure arity mismatch for ~s, expected ~s, got ~s"
                    (list procedure-name
                          (procedure-arity procedure)
                          (length args))
                    #f))
       (let ((env args* (fold-2 c-eval (cons environment '()) args )))
         (let ((inner-environment
                (fold (lambda (name value env) (env-set! env name value))
                      (push-frame! env)
                      (procedure-formals procedure) args*)))
           (let ((resulting-environment
                  result-value
                  (c-eval inner-environment (procedure-body procedure))))
             (values (pop-frame! resulting-environment)
                     result-value))))))

    (('funcall procedure arg)
     (c-eval environment `(funcall ,procedure (#{,}# ,arg))))

    ((operator operands ...)
     (apply (or (assoc-ref primitives operator)
                (scm-error 'c-eval-error "c-eval"
                           "Applying non-existant primitive operator: ~s, operands: ~s"
                           (list operator operands) #f))
            environment operands))

    ;; "f()" gets compiled to simply f
    ;; meaning that we instead use the environment to determine
    ;; if something is a variable or procedure
    (expr
     (if (literal? expr)
         (values environment expr)
         (let ((value (env-ref environment expr)))
           (if (c-procedure? value)
               (c-eval environment `(funcall ,value (#{,}#)))
               (values environment value)))))))