Differences From
Artifact [a27b738777]:
24 24
25 25 (import (chicken process-context))
26 26 (import (chicken condition))
27 27 (import (chicken pretty-print))
28 28 (import (chicken io))
29 29 (include "../scmlib/lisp-macro.scm")
30 30
31 -(: *code-depth* integer)
32 -(define *code-depth* 0) ; im sry
33 -
34 -(: indent (string -> string))
35 -(define (indent str)
36 - (define (iterate n)
37 - (if (eq? n 0) str
38 - (string-append "\t" (iterate (- n 1)))))
39 - (iterate *code-depth*))
40 31 (define (first fst . lst) fst)
41 32
42 33 (: string-reduce (list --> string))
43 34 (: words->string (list --> string))
44 35 (: separate (string list --> string))
45 36 (define (string-reduce lst) (foldl string-append "" lst))
46 37 (define (words->string lst) (foldl (lambda (a b) (string-append a " " b)) "" lst))
................................................................................
75 66 (else (abort '(exn syntax declare)))))
76 67
77 68 (define (c-define body)
78 69 (cond
79 70 ((and (list? (car body)) (>= (length body) 2))
80 71 (let ([contents (words->string (map (lambda(x) (eval-code #f x)) (cdr body)))])
81 72 (string-append (c-declare (car body))
82 - (if (>= (length (car body)) 3) (string-append " {\n" contents "\n}")
73 + (if (>= (length (car body)) 3) (string-append " {" contents "}")
83 74 (string-append " = " contents)))))
84 75 (else (abort '(exn syntax define)))))
85 76
86 77 (: c-call-function (list -> string))
87 78 (define (c-call-function body)
88 79 (unless (> (length body) 0) (abort '(exn parse call)))
89 80 (string-append
90 81 (eval-code #t (car body)) "(" (separate "," (map (lambda(x) (eval-code #t x)) (cdr body))) ")"))
82 +
83 +(: c-array-index (list -> string))
84 +(define (c-array-index body)
85 + (unless (= (length body) 2) (abort '(exn parse call)))
86 + (string-append
87 + (eval-code #t (car body))
88 + "[" (eval-code #t (cadr body)) "]"))
89 +
90 +(: c-conditional (list -> string))
91 +(define (c-conditional body)
92 + (unless (> (length body) 0) (abort '(exn parse cond)))
93 + (define (mk-block acc code)
94 + (string-append
95 + (if (eq? 'else (car code)) (string-append acc "else {")
96 + (string-append acc
97 + (if (equal? acc "") "if (" " else if (")
98 + (eval-code #t (car code)) ") {"))
99 +
100 + (string-reduce (map (lambda(x)(eval-code #f x)) (cdr code)))
101 + "}"
102 + ))
103 + (foldl mk-block "" body))
104 +
91 105
92 106 (define (c-cpp-include body)
93 107 (case (length body)
94 108 ((1) (if (string? (car body)) (string-append "#include \"" (car body) "\"\n")
95 109 (abort '(exn syntax include))))
96 110 ((2) (if (and (eqv? (car body) 'sys)
97 111 (string? (cadr body))) (string-append "#include <" (cadr body) ">\n")
................................................................................
117 131 ((and (list? a) (= (length a) 2)) ((eval-type (cadr a)) (car a)))
118 132 ((list? a) ((eval-type a)""))
119 133 (else (abort '(exn syntax function-declare argument)))))
120 134 (let ([arg-str (separate ", " (map parse-arg args))]
121 135 [ret-fn (eval-type ret)])
122 136 (ret-fn (string-append (ensure-string name) "(" arg-str ")"))))
123 137
124 -(define-macro (with-deeper-context . body)
125 - `(begin
126 - (set! *code-depth* (+ 1 *code-depth*))
127 - (first
128 - ,@body
129 - (set! *code-depth* (- *code-depth* 1))
130 - )))
131 -
132 138 (: c-statement (string -> string))
133 -(define (c-statement s) (indent (with-deeper-context (string-append s ";\n"))))
139 +(define (c-statement s) (string-append s ";"))
134 140
135 141 (: eval-type ((or null symbol list) -> ((or symbol string) -> string)))
136 142 (define (eval-type t)
137 143 ; a type object is a function that is called with a name to
138 144 ; generate a definition. this is necessary for the case of
139 145 ; arrays and function pointers, which require special syntax
140 146 (: simple ((or string symbol) --> string))
................................................................................
181 187 ('uint (simple "unsigned int"))
182 188 ('ulong (simple "unsigned long"))
183 189 ('ullong (simple "unsigned long long"))
184 190 ('llong (simple "long long"))
185 191 ('ldouble (simple "long double"))
186 192 ('u128 (simple "unsigned __int128_t"))
187 193 ('s128 (simple "__int128_t"))
194 + ('ptr (simple "void*"))
188 195 (else (simple (symbol->string t)))))
189 196 ((list? t) (parse-type t))
190 197 ((string? t) (simple t))
191 198 (else (abort '(exn syntax)))))
192 199
193 200 (define (c-construct type name body)
194 - (string-append type " " name " {\n"
195 - (string-reduce (map (lambda(x) (indent (eval-code #f x))) body))
196 - "\n}"))
201 + (string-append type " " name " {"
202 + (string-reduce (map (lambda(x) (eval-code #f x)) body))
203 + "}"))
197 204
198 205 (define (c-fn-return body)
199 206 (string-append "return " (string-reduce (map (lambda(x) (eval-code #t x)) body))))
200 207
201 -(define (c-math-op op body)
202 - (unless (= 2 (length body)) (abort '(exn syntax math)))
208 +(define (c-binary-op op body)
209 + (unless (= 2 (length body)) (abort '(exn syntax binary-op)))
203 210 (string-append "((" (eval-code #t (car body)) ")" op "(" (eval-code #t (cadr body)) "))"))
204 211
205 -(define (inter s x) (print* "-- " s ": ") (pretty-print x) x)
212 +(define (c-unary-op op body)
213 + (unless (= 1 (length body)) (abort '(exn syntax unary-op)))
214 + (string-append "(" op "(" (eval-code #t (car body)) "))"))
215 +
216 +(define (c-typecast body)
217 + (unless (= 2 (length body)) (abort '(exn syntax binary-op)))
218 + (string-append "((" ((eval-type (car body))"") ")" (eval-code #t (cadr body)) ")"))
219 +
220 +(define (wiretap s x) (print* "-- " s ": ") (pretty-print x) x)
206 221 (: eval-code (boolean list -> string))
207 222 (define (eval-code inexpr data)
208 223 (define (ctx x) inexpr (if (eq? inexpr #t) x (c-statement x)))
209 - (define (deepen n) (set! *code-depth* (+ *code-depth* n)))
210 224 (: dispatch (list -> string))
211 225 (define (dispatch form body)
212 226 (case form
213 227 ('* (eval-code inexpr (evaluate-list body)))
214 228 ('= (eval-code inexpr (evaluate-list (cons 'begin body))))
215 229 ('@ (eval (cons 'begin body)) "")
216 230 ('use (c-cpp-include body))
217 - ('def (first (c-statement (with-deeper-context (c-define body))) ))
218 - ('decl (first (c-statement (with-deeper-context (c-declare body))) ))
231 + ('def (first (c-statement (c-define body))) )
232 + ('decl (first (c-statement (c-declare body)) ))
219 233 ('call (ctx (c-call-function body)))
234 + ('cond (c-statement (c-conditional body)))
220 235 ('list (first (string-append "{" (separate "," (map (lambda(x) (eval-code #t x)) body)) "}") ))
221 236 ('struct (first (ctx (c-construct "struct" (car form) (cdr form))) ))
222 237 ('enum (first (ctx (c-construct "enum" (car form) (cdr form))) ))
223 238 ('ret (c-statement (c-fn-return body)))
224 - ('add (c-math-op "+" body))
225 - ('add-> (ctx (c-math-op "+=" body)))
226 - ('sub (c-math-op "-" body))
227 - ('sub-> (ctx (c-math-op "-=" body)))
228 - ('mul (c-math-op "*" body))
229 - ('mul-> (ctx (c-math-op "*=" body)))
230 - ('div (c-math-op "/" body))
231 - ('div-> (ctx (c-math-op "/=" body)))
232 - ('== (c-math-op "==" body))
233 - ('-> (ctx (c-math-op "=" body)))
234 - ('→ (ctx (c-math-op "=" body)))
239 + ('cast (c-typecast body))
240 + ('idx (c-array-index body))
241 + ('add (c-binary-op "+" body))
242 + ('add-> (ctx (c-binary-op "+=" body)))
243 + ('sub (c-binary-op "-" body))
244 + ('sub-> (ctx (c-binary-op "-=" body)))
245 + ('mul (c-binary-op "*" body))
246 + ('mul-> (ctx (c-binary-op "*=" body)))
247 + ('div (c-binary-op "/" body))
248 + ('div-> (ctx (c-binary-op "/=" body)))
249 + ('ref (c-unary-op "&" body))
250 + ('eq (c-binary-op "==" body))
251 + ('neq (c-binary-op "!=" body))
252 + ('gte (c-binary-op ">=" body))
253 + ('lte (c-binary-op "<=" body))
254 + ('lt (c-binary-op "<" body))
255 + ('gt (c-binary-op ">" body))
256 + ('-> (ctx (c-binary-op "=" body)))
257 + ('→ (ctx (c-binary-op "=" body)))
235 258 ('; ";")
236 259 (else (string-append "<UNFOUND FORM " (symbol->string form) ">"))
237 260 )))
238 261 (cond
239 262 ((null? data) "")
240 263 ((symbol? data) (symbol->string data))
241 264 ((string? data) (string-append "\"" data "\""))