Overview
| Comment: | add support for conditionals, array indexing, and reference-taking |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
844294c3a498c4ada3ad69a274503e6f |
| User & Date: | lexi on 2019-07-24 22:36:50 |
| Other Links: | manifest | tags |
Context
|
2019-07-25
| ||
| 11:06 | add nkvd.c and make infra check-in: 7ba40af07e user: lexi tags: trunk | |
|
2019-07-24
| ||
| 22:36 | add support for conditionals, array indexing, and reference-taking check-in: 844294c3a4 user: lexi tags: trunk | |
|
2019-07-23
| ||
| 12:32 | add sexcp check-in: 520b38deac user: lexi tags: trunk | |
Changes
Modified sexpc/example.cse from [58b3a515c7] to [d3af63ab24].
14 14 ; (@ … ) introduces a block of Scheme code that 15 15 ; is evaluated in the program's environment, but 16 16 ; whose value is silently ignored. this makes it 17 17 ; good for defining globals you intend to use 18 18 ; later in the program with (* … ) or (= … ) 19 19 ; blocks - see the paragraph below 20 20 (define (sayl str) 21 - `(add-> total (call write 1 21 + `(add-> total (call write 1 22 22 ; the return value of a scheme expression will 23 23 ; be evaluated just like any other expression 24 24 ; and transformed into C code, so we can rely 25 25 ; on existing syntax instead of haven't to 26 26 ; generate raw strings of C 27 27 ,(string-append str "\\n") 28 28 ,(+ 1 (string-length str)))))) 29 29 30 30 (decl sayhello ((ptr char) → int)) 31 +(decl usage (() => ())) 31 32 (def (total size_t) 0) 32 33 33 34 (def (main int (argc int) (argv (array (ptr char)))) 34 - (ret (call sayhello "dumbass"))) 35 + (def (voidptr (ptr ())) (cast (ptr ()) argv)) 36 + (cond ((neq argc 2) (call usage)) 37 + (else (call sayhello (idx argv 1))))) 35 38 36 39 (def (sayhello int (name (ptr char))) 37 40 (* sayl "hello…") 38 41 ; a list prefixed with * indicates that it 39 42 ; should be evaluated as a scheme expression 40 43 ; and its result then processed, instead of 41 44 ; being processed directly like (call) or ................................................................................ 42 45 ; (def). scheme expressions may be inserted 43 46 ; anywhere a normal sexpc expression can. or 44 47 ; we could instead write (= (sayl "hello…")) 45 48 ; to accomplish the same effect; (= … ) is 46 49 ; really just shorthand for (* begin … ) 47 50 48 51 (call write 1 name (call strlen name)) 49 - (ret total) 50 -) 52 + (ret total)) 53 + 54 +(def (usage void ()) 55 + (* sayl "usage: example <name>")) 56 +
Modified sexpc/sexpc.scm from [a27b738777] to [46b6c9a575].
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 "\""))
Modified sexpc/type-tests.scm from [47bc0863a3] to [3a7d364dcb].
17 17 (const (ptr float)) 18 18 (ptr int) 19 19 (ullong schar -> (ptr (bool u128 -> ldouble))) 20 20 (int -> chungus_t) 21 21 (ptr (int -> chungus_t)) 22 22 (array 5 (ptr (int -> chungus_t))) 23 23 ((array 5 (ptr int)) -> (const (ptr (array 3 int)))) 24 - ; int (((*const (v(int (*(())[5])))))[3]) 25 - ; int (* const v(int *[5]))[3] 26 -(array (const (ptr (char u128 -> (ptr (array 5 bool)))))) 24 + (array (const (ptr (char u128 -> (ptr (array 5 bool)))))) 27 25 28 26 (array 5 (const (ref char))))) 29 27 30 28 (map test tests)