Overview
| Comment: | add sexcp |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
520b38deac100b0d9179113569423411 |
| User & Date: | lexi on 2019-07-23 12:32:27 |
| Other Links: | manifest | tags |
Context
|
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 | |
|
2019-07-21
| ||
| 06:35 | add clipserv check-in: 6a5d1f9f67 user: lexi tags: trunk | |
Changes
Modified clib/compose.c from [e0c5b0d583] to [d981619adf].
25 25 #define _p(str) { sizeof str - 1, str } 26 26 27 27 typedef struct safestr { 28 28 union { 29 29 const char* ptr; 30 30 char* mutptr; 31 31 }; // im sorry okay 32 - bool heap; 32 +# ifndef k_static 33 + bool heap; 34 +# endif 33 35 size_t len; 34 36 } safestr; 35 37 36 -void delstr(safestr s) fn ({ 37 - if (s.heap) { free(s.mutptr); } 38 -}); 38 +#ifndef k_static 39 + void delstr(safestr s) fn ({ 40 + if (s.heap) { free(s.mutptr); } 41 + }); 42 +#endif 39 43 40 44 void clrstr(safestr* s) fn ({ 41 - delstr(*s); 42 - s->heap = false; 45 +# ifndef k_static 46 + delstr(*s); 47 + s->heap = false; 48 +# endif 43 49 s->ptr = NULL; 44 50 s->len = 0; 45 51 }) 46 52 47 -char* compose(pstr* lst,size_t ct, size_t* strsz) fn({ 53 +size_t pstrsum(pstr* lst,size_t ct) fn({ 48 54 size_t len = 0; 49 55 for (size_t i = 0; i < ct; ++i) { 50 56 if (lst[i].len == 0) { 51 57 if (lst[i].ptr == NULL) continue; 52 58 lst[i].len = strlen(lst[i].ptr); 53 59 } 54 60 len += lst[i].len; 55 61 } 56 - if (strsz != NULL) *strsz = len; 57 - if (len == 0) return NULL; 58 - 59 - char* str = malloc(len + 1); 60 - char* ptr = str; 62 +}) 63 + 64 +char* pstrcoll(pstr* lst, size_t ct, char* ptr) fn({ 61 65 for (size_t i = 0; i < ct; ++i) { 62 66 if (lst[i].len == 0) continue; 63 67 strncpy(ptr,lst[i].ptr,lst[i].len); 64 68 ptr += lst[i].len; 65 69 } 70 + return ptr; 71 +}) 72 + 73 +#ifndef k_static 74 +char* compose(pstr* lst,size_t ct, size_t* strsz) fn({ 75 + size_t len = pstrsum(lst,ct) 76 + if (strsz != NULL) *strsz = len; 77 + if (len == 0) return NULL; 78 + 79 + char* str = malloc(len + 1); 80 + char* ptr = pstrcoll(lst, ct, ptr); 66 81 *ptr = 0; 67 82 return str; 68 83 }); 84 +#endif 85 + 86 +char* impose(pstr* lst,size_t ct, size_t* strsz, char* buf) fn({ 87 + size_t len = pstrsum(lst,ct); 88 + if (strsz != NULL) *strsz = len; 89 + if (len == 0) return NULL; 90 + 91 + char* ptr = pstrcoll(lst, ct, buf); 92 + *ptr = 0; 93 + return ptr; 94 +}); 69 95 96 +char* imprint(pstr lst, size_t* strsz, char* buf) fn({ 97 + size_t len = pstrsum(&lst,1); 98 + if (strsz != NULL) *strsz = len; 99 + if (len == 0) return NULL; 100 + 101 + char* ptr = pstrcoll(&lst,1,buf); 102 + *ptr = 0; 103 + return ptr; 104 +}); 105 +#undef fn
Modified clipserv/clip.b from [08bfad81fd] to [9f380b471d].
187 187 new-args: join new-args i ] ] 188 188 main new-args yes 189 189 ] 190 190 true [ usage ] 191 191 ] 192 192 ] 193 193 194 -quit/return main args no 194 +success: main args no 195 +if eq? success true [ 196 + quit/return 0 197 +] 198 +quit/return 1
Added scmlib/lisp-macro.scm version [ad02b3f2ba].
1 +; [ʞ] lisp-macro 2 +; ~ lexi hale <lexi@hale.su> 3 +; © affero general public license 4 +; > (load "lib/lisp-macro.scm") 5 + 6 +; enable use of the define-macro syntax in chicken scheme 7 +; ex: (define-macro (if-or-f . body) 8 +; `(if ,(car body) ,(cadr body) #f)) 9 + 10 +(define-syntax define-macro 11 + (er-macro-transformer (lambda (exp r c) 12 + `(define-syntax ,(caadr exp) 13 + (er-macro-transformer 14 + (lambda (,(cdadr exp) id-rename id-compare) 15 + (let ((,(cdadr exp) (cdr ,(cdadr exp)))) 16 + ,@(cddr exp))))))))
Added scmlib/select.scm version [ce284edc9d].
1 +; [ʞ] select.scm 2 +; ~ lexi hale <lexi@hale.su> 3 +; © CC0 / public domain 4 +; > (include "lisp-macro.scm") 5 +; (include "select.scm") 6 +; ? a reimplementation of (case) that lets you 7 +; specify your own evaluator function. same syntax, 8 +; except the expression to evaluate is preceeded by 9 +; a predicate function 10 +; = (select equal? "weed" 11 +; ("weed" 420) 12 +; ("sex" 69) 13 +; (else 42069) 14 + 15 +(define-macro (select . body) 16 + (let* ([eqfn (list-ref body 0)] 17 + [expr (list-ref body 1)] 18 + [cases (cddr body)] 19 + [result (gensym)]) 20 + (define (make-cond-entry case) 21 + (let ([case-expr (car case)] 22 + [func (cdr case)]) 23 + (if (eqv? case-expr 'else) (cons #t func) 24 + (cons (list eqfn result case-expr) func)))) 25 + (define cond-entries (map make-cond-entry cases)) 26 + `(let ([,result ,expr]) (cond ,@cond-entries)))) 27 + 28 +(define-macro (maybe . body) 29 + (let (( result (gensym) )) 30 + `(let (( ,result ,(cadr body) )) 31 + (if ,result (let (( ,(car body) ,result )) 32 + ,(cddr body)) 33 + #f))))
Added sexpc/example.cse version [58b3a515c7].
1 +; [ʞ] example.cse 2 +; ~ lexi hale <lexi@hale.su> 3 +; - vim: ft=scheme 4 +; © CCO / public domain 5 +; $ ./sexpc example.cse 6 +; ? this file is an example program that can be 7 +; transpiled to valid C with sexpc.scm. 8 +(use sys "unistd.h") 9 +(use sys "stddef.h") 10 +(use sys "stdint.h") 11 +(use sys "string.h") 12 + 13 +(@ (: sayl (string -> list)) 14 + ; (@ … ) introduces a block of Scheme code that 15 + ; is evaluated in the program's environment, but 16 + ; whose value is silently ignored. this makes it 17 + ; good for defining globals you intend to use 18 + ; later in the program with (* … ) or (= … ) 19 + ; blocks - see the paragraph below 20 + (define (sayl str) 21 + `(add-> total (call write 1 22 + ; the return value of a scheme expression will 23 + ; be evaluated just like any other expression 24 + ; and transformed into C code, so we can rely 25 + ; on existing syntax instead of haven't to 26 + ; generate raw strings of C 27 + ,(string-append str "\\n") 28 + ,(+ 1 (string-length str)))))) 29 + 30 +(decl sayhello ((ptr char) → int)) 31 +(def (total size_t) 0) 32 + 33 +(def (main int (argc int) (argv (array (ptr char)))) 34 + (ret (call sayhello "dumbass"))) 35 + 36 +(def (sayhello int (name (ptr char))) 37 + (* sayl "hello…") 38 + ; a list prefixed with * indicates that it 39 + ; should be evaluated as a scheme expression 40 + ; and its result then processed, instead of 41 + ; being processed directly like (call) or 42 + ; (def). scheme expressions may be inserted 43 + ; anywhere a normal sexpc expression can. or 44 + ; we could instead write (= (sayl "hello…")) 45 + ; to accomplish the same effect; (= … ) is 46 + ; really just shorthand for (* begin … ) 47 + 48 + (call write 1 name (call strlen name)) 49 + (ret total) 50 +)
Added sexpc/sexpc.scm version [a27b738777].
1 +; [ʞ] sexpc.scm - sexp→c converter 2 +; ~ lexi hale <lexi@hale> 3 +; © GNU Affero GPL v3 4 +; $ chicken-csc -O5 sexpc.scm; strip sexpc 5 +; > ./sexpc <file> 6 +; ? a tool to convert sheets of s-expressions into 7 +; valid C, enabling the use of Scheme as a 8 +; preprocessor language. it also generates C type 9 +; definitions from a human-readable syntax, 10 +; removing the difficulties introduced by C's 11 +; legendarily inscrutable compound type syntax: 12 +; e.g. (def r (array (const (ptr (char u128 -> 13 +; (ptr (array 5 bool))))))), 14 +; which represents an array of const pointers to 15 +; functions taking a char and a 128-bit integer, 16 +; and returning a pointer to an array of five bools. 17 +; this emits the C type: 18 +; _Bool (((*(*const (((v)[])))(char, unsigned 19 +; __int128_t)))[5]) 20 +; (as i'm sure you immediately guessed) 21 +; 22 +; → no dependencies besides the lisp-macro.scm file 23 +; bundled with it, and the chicken stdlib. 24 + 25 +(import (chicken process-context)) 26 +(import (chicken condition)) 27 +(import (chicken pretty-print)) 28 +(import (chicken io)) 29 +(include "../scmlib/lisp-macro.scm") 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 +(define (first fst . lst) fst) 41 + 42 +(: string-reduce (list --> string)) 43 +(: words->string (list --> string)) 44 +(: separate (string list --> string)) 45 +(define (string-reduce lst) (foldl string-append "" lst)) 46 +(define (words->string lst) (foldl (lambda (a b) (string-append a " " b)) "" lst)) 47 +(define (separate delim lst) (foldl (lambda (a b) 48 + (cond ((equal? a "") b) 49 + ((equal? b "") a) 50 + (else (string-append a delim b)))) "" lst)) 51 + 52 +(: ensure-string ((or string symbol) -> string)) 53 +(define (ensure-string s) (if (string? s) s (if (symbol? s) (symbol->string s) 54 + (abort '(exn bad-string-or-symbol))))) 55 +(define (handle fn) 56 + (define (err text) (string-append "\x1b[1;31m(fatal) \x1b[m" text)) 57 + (condition-case (fn) 58 + [(exn file) (display (err "could not open file"))] 59 + [var () (display (err "an unknown error occurred"))])) 60 + 61 +(define (make-evaluator) 62 + (let ((*eval-env* (interaction-environment))) 63 + (lambda (lst) (eval lst *eval-env*)))) 64 + 65 +(define evaluate-list (make-evaluator)) 66 + 67 +(define (c-def-function body) "<FUNC>") 68 +(define (c-declare body) 69 + (cond ((>= (length body) 3) 70 + (let ([fn-name (list-ref body 0)] 71 + [fn-return (list-ref body 1)] 72 + [fn-args (list-tail body 2)]) 73 + (c-function-decl fn-return fn-name fn-args))) 74 + ((eqv? (length body) 2) ((eval-type (cadr body)) (car body))) 75 + (else (abort '(exn syntax declare))))) 76 + 77 +(define (c-define body) 78 + (cond 79 + ((and (list? (car body)) (>= (length body) 2)) 80 + (let ([contents (words->string (map (lambda(x) (eval-code #f x)) (cdr body)))]) 81 + (string-append (c-declare (car body)) 82 + (if (>= (length (car body)) 3) (string-append " {\n" contents "\n}") 83 + (string-append " = " contents))))) 84 + (else (abort '(exn syntax define))))) 85 + 86 +(: c-call-function (list -> string)) 87 +(define (c-call-function body) 88 + (unless (> (length body) 0) (abort '(exn parse call))) 89 + (string-append 90 + (eval-code #t (car body)) "(" (separate "," (map (lambda(x) (eval-code #t x)) (cdr body))) ")")) 91 + 92 +(define (c-cpp-include body) 93 + (case (length body) 94 + ((1) (if (string? (car body)) (string-append "#include \"" (car body) "\"\n") 95 + (abort '(exn syntax include)))) 96 + ((2) (if (and (eqv? (car body) 'sys) 97 + (string? (cadr body))) (string-append "#include <" (cadr body) ">\n") 98 + (abort '(exn syntax include sys)))) 99 + (else (abort '(exn syntax include))))) 100 + 101 +(define (and* . body) 102 + (if (null? body) #t 103 + (if (eq? #f (car body)) #f 104 + (apply and* (cdr body))))) 105 + 106 +(: c-function-decl (symbol 107 + symbol 108 + (list-of (or null 109 + string 110 + (pair (or symbol 111 + (list-of symbol)) symbol))) -> string)) 112 +(define (c-function-decl ret name args) 113 + (define (parse-arg a) 114 + (cond ((null? a) "void") 115 + ((string? a) a) 116 + ((symbol? a) ((eval-type a)"")) 117 + ((and (list? a) (= (length a) 2)) ((eval-type (cadr a)) (car a))) 118 + ((list? a) ((eval-type a)"")) 119 + (else (abort '(exn syntax function-declare argument))))) 120 + (let ([arg-str (separate ", " (map parse-arg args))] 121 + [ret-fn (eval-type ret)]) 122 + (ret-fn (string-append (ensure-string name) "(" arg-str ")")))) 123 + 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 +(: c-statement (string -> string)) 133 +(define (c-statement s) (indent (with-deeper-context (string-append s ";\n")))) 134 + 135 +(: eval-type ((or null symbol list) -> ((or symbol string) -> string))) 136 +(define (eval-type t) 137 + ; a type object is a function that is called with a name to 138 + ; generate a definition. this is necessary for the case of 139 + ; arrays and function pointers, which require special syntax 140 + (: simple ((or string symbol) --> string)) 141 + (define (simple x) (lambda (n) (if (equal? "" n) x (string-append x " " (ensure-string n))))) 142 + (define (wrap ty name inner) (lambda (n) 143 + (string-append (car ty) ((eval-type inner) 144 + (string-append (cdr ty) (car name) (ensure-string n) (cdr name)))))) 145 + 146 + (define (parse-function-def t) 147 + (if (>= (length t) 3) ; function def?) 148 + (let ([arrow (list-ref t (- (length t) 2))]) 149 + (if (or (eqv? arrow '->) (eqv? arrow '→) (eqv? arrow '=>)) ; function def! 150 + (let* ([args (butlast (butlast t))] ; rrrrrrgh 151 + [ret (list-ref t (- (length t) 1))] 152 + [arg-map (map (lambda (x) ((eval-type x)"")) args)]) 153 + (lambda (n) (c-function-decl ret n arg-map))) 154 + #f)) 155 + #f)) 156 + (define (parse-type t) 157 + (or (parse-function-def t) 158 + ; not a function 159 + (case (car t) 160 + ('ptr (wrap '["".""] '["(*".")"] (cadr t))) 161 + ('ref (wrap '["".""] '["(&".")"] (cadr t))) ; for C++ support 162 + ('const (wrap '["".""] '["const (".")"] (cadr t))) 163 + ('struct (wrap '["struct ".""] '["".""] (cadr t))) 164 + ('enum (wrap '["enum ".""] '["".""] (cadr t))) 165 + ('volatile (wrap '["".""] '["volatile(".")"] (cadr t))) 166 + ('onlyptr (wrap '["".""] '["(*restrict ".")"] (cadr t))) 167 + ('static (wrap '["".""] '["static ".""] (cadr t))) 168 + ('array (if (null? (cddr t)) (wrap '["".""] '["((".")[])"] 169 + (cadr t)) 170 + (wrap '["".""] [cons "((" (string-append ")[" (eval-code #t (cadr t)) "])" )] 171 + (caddr t)))) 172 + (else (abort '(exn syntax)))))) 173 + 174 + (cond 175 + ((null? t) (simple "void")) 176 + ((symbol? t) (case t 177 + ('bool (simple "_Bool")) 178 + ('uchar (simple "unsigned char")) 179 + ('schar (simple "signed char")) 180 + ('ushort (simple "unsigned short")) 181 + ('uint (simple "unsigned int")) 182 + ('ulong (simple "unsigned long")) 183 + ('ullong (simple "unsigned long long")) 184 + ('llong (simple "long long")) 185 + ('ldouble (simple "long double")) 186 + ('u128 (simple "unsigned __int128_t")) 187 + ('s128 (simple "__int128_t")) 188 + (else (simple (symbol->string t))))) 189 + ((list? t) (parse-type t)) 190 + ((string? t) (simple t)) 191 + (else (abort '(exn syntax))))) 192 + 193 +(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}")) 197 + 198 +(define (c-fn-return body) 199 + (string-append "return " (string-reduce (map (lambda(x) (eval-code #t x)) body)))) 200 + 201 +(define (c-math-op op body) 202 + (unless (= 2 (length body)) (abort '(exn syntax math))) 203 + (string-append "((" (eval-code #t (car body)) ")" op "(" (eval-code #t (cadr body)) "))")) 204 + 205 +(define (inter s x) (print* "-- " s ": ") (pretty-print x) x) 206 +(: eval-code (boolean list -> string)) 207 +(define (eval-code inexpr data) 208 + (define (ctx x) inexpr (if (eq? inexpr #t) x (c-statement x))) 209 + (define (deepen n) (set! *code-depth* (+ *code-depth* n))) 210 + (: dispatch (list -> string)) 211 + (define (dispatch form body) 212 + (case form 213 + ('* (eval-code inexpr (evaluate-list body))) 214 + ('= (eval-code inexpr (evaluate-list (cons 'begin body)))) 215 + ('@ (eval (cons 'begin body)) "") 216 + ('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))) )) 219 + ('call (ctx (c-call-function body))) 220 + ('list (first (string-append "{" (separate "," (map (lambda(x) (eval-code #t x)) body)) "}") )) 221 + ('struct (first (ctx (c-construct "struct" (car form) (cdr form))) )) 222 + ('enum (first (ctx (c-construct "enum" (car form) (cdr form))) )) 223 + ('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))) 235 + ('; ";") 236 + (else (string-append "<UNFOUND FORM " (symbol->string form) ">")) 237 + ))) 238 + (cond 239 + ((null? data) "") 240 + ((symbol? data) (symbol->string data)) 241 + ((string? data) (string-append "\"" data "\"")) 242 + ((char? data) (apply string (list #\' data #\'))) 243 + ((number? data) (number->string data)) 244 + ((list? data) (let ([form (car data)] 245 + [body (cdr data)]) 246 + (dispatch form body))) 247 + (else (abort '(exn syntax))))) 248 + 249 +(define (parse-code file) (map (lambda(x) (eval-code #f x)) file)) 250 + 251 +(define (compile filename) 252 + (let ([file (if (equal? filename "-") (read-list) 253 + (handle (lambda() 254 + (call-with-input-file filename read-list))))]) 255 + (string-reduce (parse-code file)))) 256 + 257 +(: usage (--> string)) 258 +(define (usage) "usage: sexpc <file>") 259 + 260 +(define (cull-args args switches params) 261 + (define (parse-switch switch) 262 + (cond 263 + ((equal? switch "-") "-") 264 + ((eqv? (string-ref switch 1) #\-) (substring switch 2)) 265 + (else (map string (string->list (substring switch 1)))))) 266 + (define (is-switch arg) 267 + (eqv? (string-ref arg 0) #\-)) 268 + (define (split p) 269 + (cons (flatten (map parse-switch switches)) p)) 270 + (let* ([hd (if (null? args) '() (car args))] 271 + [tl (if (null? hd) '() (cdr args))]) 272 + (cond 273 + ((null? args) (split params)) 274 + ((equal? "--" hd) (split (append params tl))) 275 + ((is-switch hd) (cull-args tl (cons hd switches) params)) 276 + (else (cull-args tl switches 277 + (cons hd params)))))) 278 + 279 +(define (main args) 280 + (let* ([switches-and-params (cull-args args '() '())] 281 + [switches (car switches-and-params)] 282 + [params (cdr switches-and-params)]) 283 + (cond 284 + ((null? params) (usage)) 285 + ((eqv? (length params) 1) (compile (car params))) 286 + (else (usage))))) 287 + 288 +(cond-expand (csi) (else (display (main (command-line-arguments)))))
Added sexpc/type-tests.scm version [47bc0863a3].
1 +(include "sexpc.scm") 2 +((eval-type '()) 'v); 3 + 4 +(define (test form) 5 + (print ((eval-type form) 'v))) 6 + 7 +(define tests '( 8 + int char float uint 9 + (struct chungus_t) 10 + (ptr int) (array char) 11 + (array 5 (const int)) (const int) 12 + (const (ptr (array 5 (const int)))) 13 + (const (ptr int)) 14 + (array 5 (ptr int)) 15 + (ref (array 5 int)) 16 + (ptr (array (volatile char))) 17 + (const (ptr float)) 18 + (ptr int) 19 + (ullong schar -> (ptr (bool u128 -> ldouble))) 20 + (int -> chungus_t) 21 + (ptr (int -> chungus_t)) 22 + (array 5 (ptr (int -> chungus_t))) 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)))))) 27 + 28 + (array 5 (const (ref char))))) 29 + 30 +(map test tests)