aboutsummaryrefslogtreecommitdiff
path: root/module/c/eval.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/c/eval.scm')
-rw-r--r--module/c/eval.scm265
1 files changed, 0 insertions, 265 deletions
diff --git a/module/c/eval.scm b/module/c/eval.scm
deleted file mode 100644
index 67d0075d..00000000
--- a/module/c/eval.scm
+++ /dev/null
@@ -1,265 +0,0 @@
-(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)))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 14:24:08 +0200