Overview
| Comment: | add structure macro |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
e856b9f3a88b93753e314f71e1bf9812 |
| User & Date: | lexi on 2019-07-27 06:29:59 |
| Other Links: | manifest | tags |
Context
|
2019-07-27
| ||
| 06:30 | fix typo check-in: ec168497f7 user: lexi tags: trunk | |
| 06:29 | add structure macro check-in: e856b9f3a8 user: lexi tags: trunk | |
|
2019-06-24
| ||
| 09:24 | updates check-in: d425e8a7c7 user: lexi tags: trunk | |
Changes
Added lib/fn-struct.scm version [70386af811].
1 +; [ʞ] fn-struct.scm 2 +; ~ lexi hale <lexi@hale.su> 3 +; © affero general public license 4 +; > (load "lib/struct.scm") 5 +; 6 +; generates immutable, relatively efficient structs. declare 7 +; a struct type x with 8 +; (define x (struct 'field1 'field2) 9 +; create a record y of that type with 10 +; (define y (x 123 456)) 11 +; access field1 of record y with 12 +; (y 'field1) 13 +; update field2 of record y with 14 +; (y 'field2 123) → new record (field1 = 123; field2 = 123) 15 +; 16 +; this unit also includes a few utility function that 17 +; chicken scheme conveniently "forgot." i apologize for 18 +; the implementation of (list-head). i was very tired. 19 + 20 +; return a sub-list of lst up to ct (inverse of list-tail) 21 +(define (list-head lst ct) 22 + (let* ([reverse-lst (reverse lst)] 23 + [idx (- (length lst) (+ 1 ct))]) 24 + (reverse (list-tail reverse-lst idx)))) 25 + ; i'm not proud of this 26 + 27 +; search for the first occurence of `term` in list lst. 28 +; equal? is used by default; an alternate predicate may 29 +; be passed after `term` 30 +(define (member-index lst term . opt) 31 + (let ([predicate (if (eq? '() opt) equal? 32 + (car opt))]) 33 + (define (search idx l) 34 + (if (eq? l '()) #f 35 + (if (predicate (car l) term) idx 36 + (search (+ 1 idx) (cdr l))))) 37 + (search 0 lst))) 38 + 39 +; generate a new struct type and return it as a function 40 +; that may be called to instantiate that type. 41 +(define (struct . keys) 42 + (define (generate-record . vals) 43 + ; the function returned by a (struct) call and called 44 + ; to generate a new struct by functional-update syntax 45 + (define (struct-ref key) 46 + ; searches the struct for the named key and if found 47 + ; return its index, otherwise return #f 48 + (let ([query-idx (member-index keys key)]) 49 + (if (eq? #f query-idx) #f 50 + (list-ref vals query-idx)))) 51 + (define (update-record key val) 52 + ; return a new version of this construct with the same 53 + ; field names and values except for { key = val } 54 + (let* ([field-idx (member-index keys key)] 55 + [new-tail (list-tail vals (+ 1 field-idx))] 56 + [new-head (list-head vals (- field-idx 1))]) 57 + (apply generate-record (append new-head (list val) new-tail)))) 58 + 59 + ; are values specified for every field and no more? 60 + ; TODO: consider loosening the restriction - could 61 + ; there be some use to allowing the used to add fields 62 + ; only accessible through the record->list facility? 63 + (if (not (= (length vals) (length keys))) #f 64 + (lambda access 65 + ; returned by generate-record, this function is called 66 + ; whenever a struct is accessed 67 + (case (length access) 68 + ;determine operation to perform 69 + ((0) vals) ; return list of values 70 + ((1) (struct-ref (car access))); search for value 71 + ((2) (update-record (car access) (cadr access))) 72 + (else #f))))) ; no other functions currently available 73 + 74 + ; keys are now stored in the closure; return the 75 + ; (generate-record) function to the user so she can 76 + ; call it to instantiate the defined struct. 77 + generate-record)
Added lib/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))))
Modified lib/struct.scm from [06f94eb978] to [7cd42aa5f2].
1 1 ; [ʞ] struct.scm 2 2 ; ~ lexi hale <lexi@hale.su> 3 -; © affero general public license 4 -; > (load "lib/struct.scm") 5 -; 6 -; generates immutable, relatively efficient structs. declare 7 -; a struct type x with 8 -; (define x (struct 'field1 'field2) 9 -; create a record y of that type with 10 -; (define y (x 123 456)) 11 -; access field1 of record y with 12 -; (y 'field1) 13 -; update field2 of record y with 14 -; (y 'field2 123) → new record (field1 = 123; field2 = 123) 15 -; 16 -; this unit also includes a few utility function that 17 -; chicken scheme conveniently "forgot." i apologize for 18 -; the implementation of (list-head). i was very tired. 3 +; $ csc -X fail.scm … 4 +; © affero gpl v3 5 +; > (include "lisp-macro.scm") 6 +; ? a typed struct mechanism for scheme, because the 7 +; srfi ones suck ass and don't support FRU syntax. 8 +; X (structure user (name . string) 9 +; (age . integer) 10 +; (pw . string) 11 +; gecos) 12 +; (define stacy (user name: "stacy" 13 +; age: 26 14 +; pw: "swordfish")) 15 +; (if (user? stacy) (user.name stacy)) 16 +; (define oldstacy (user stacy age: 69)) 17 +; (user.name oldstacy) 18 +; (user.age oldstacy) 19 + 20 +(include "lisp-macro.scm") 21 + 22 +(import (chicken pretty-print) 23 + (chicken keyword)) 24 + 25 +(begin-for-syntax (import (chicken keyword))) 26 + ; i cannot believe this worked 27 + 28 +(define-macro (structure . body) 29 + (define (uniq lst) 30 + (define (in? x l) 31 + (if (null? l) #f 32 + (if (eqv? x (car l)) #t 33 + (in? x (cdr l))))) 34 + (define (loop acc hd) 35 + (if (null? hd) acc 36 + (if (in? (car hd) acc) (loop acc (cdr hd)) 37 + (loop (cons (car hd) acc) (cdr hd))))) 38 + (loop '() lst)) 39 + 40 + (define (symsuf sym . suffix) 41 + (string->symbol (apply string-append (cons (symbol->string sym) suffix)))) 42 + 43 + (define (emit-field sname idx f) 44 + (let* ([prop (cond ((symbol? f) (cons f 'any)) 45 + ((pair? f) f))] 46 + [name (car prop)] 47 + [type (cdr prop)] 48 + [fn (symsuf sname "." (symbol->string name))]) 49 + `(begin 50 + (: ,fn ((pair symbol vector) --> ,type)) 51 + (define (,fn struct) 52 + (if (,(symsuf sname "?") struct) (vector-ref (cdr struct) ,idx) 53 + (error ,(string-append "argument is not of type " (symbol->string sname)))))))) 54 + 55 + (define (reduce-fields sname idx fields) 56 + (if (null? fields) '() 57 + (cons (emit-field sname idx (car fields)) 58 + (reduce-fields sname (+ 1 idx) (cdr fields))))) 59 + 60 + (define (emit-pred name typesym) 61 + (let ([fn (symsuf name "?")]) 62 + `(begin (: ,fn (any --> boolean)) 63 + (define (,fn candidate) (and (pair? candidate) 64 + (eq? (quote ,typesym) (car candidate)) 65 + (vector? (cdr candidate))))))) 66 + (define (extract-type field) 67 + (cond ((symbol? field) 'any) 68 + ((pair? field) (cdr field)))) 19 69 20 -; return a sub-list of lst up to ct (inverse of list-tail) 21 -(define (list-head lst ct) 22 - (let* ([reverse-lst (reverse lst)] 23 - [idx (- (length lst) (+ 1 ct))]) 24 - (reverse (list-tail reverse-lst idx)))) 25 - ; i'm not proud of this 70 + (define (emit-def name types) 71 + `((define-type ,name (pair symbol (vector ,@types))))) 26 72 27 -; search for the first occurence of `term` in list lst. 28 -; equal? is used by default; an alternate predicate may 29 -; be passed after `term` 30 -(define (member-index lst term . opt) 31 - (let ([predicate (if (eq? '() opt) equal? 32 - (car opt))]) 33 - (define (search idx l) 34 - (if (eq? l '()) #f 35 - (if (predicate (car l) term) idx 36 - (search (+ 1 idx) (cdr l))))) 37 - (search 0 lst))) 73 + (define (emit-gen name types typesym fields) 74 + (define (fld-get idx fld) 75 + (let ([name (if (symbol? fld) fld (car fld))]) 76 + `(get-keyword ,(string->keyword (symbol->string name)) spec 77 + (lambda() (safe-vector-ref basis ,idx))))) 78 + (define (reduce-flds idx flds) 79 + (if (null? flds) '() 80 + (cons (fld-get idx (car flds)) 81 + (reduce-flds (+ 1 idx) (cdr flds))))) 82 + `((: ,name (#!rest (or symbol ,@(uniq types)) --> ,name )) 83 + (define (,name . args) 84 + (define (safe-vector-ref v i) (if (null? v) (error "all struct fields need to be specified unless functional record update syntax is in use") 85 + (vector-ref v i))) 86 + (let* ([basis (if (,(symsuf name "?") (car args)) (cdar args) '())] 87 + [spec (if (null? basis) args (cdr args))]) 88 + (cons (quote ,typesym) 89 + (vector ,@(reduce-flds 0 fields) 38 90 39 -; generate a new struct type and return it as a function 40 -; that may be called to instantiate that type. 41 -(define (struct . keys) 42 - (define (generate-record . vals) 43 - ; the function returned by a (struct) call and called 44 - ; to generate a new struct by functional-update syntax 45 - (define (struct-ref key) 46 - ; searches the struct for the named key and if found 47 - ; return its index, otherwise return #f 48 - (let ([query-idx (member-index keys key)]) 49 - (if (eq? #f query-idx) #f 50 - (list-ref vals query-idx)))) 51 - (define (update-record key val) 52 - ; return a new version of this construct with the same 53 - ; field names and values except for { key = val } 54 - (let* ([field-idx (member-index keys key)] 55 - [new-tail (list-tail vals (+ 1 field-idx))] 56 - [new-head (list-head vals (- field-idx 1))]) 57 - (apply generate-record (append new-head (list val) new-tail)))) 91 + )))))) 58 92 59 - ; are values specified for every field and no more? 60 - ; TODO: consider loosening the restriction - could 61 - ; there be some use to allowing the used to add fields 62 - ; only accessible through the record->list facility? 63 - (if (not (= (length vals) (length keys))) #f 64 - (lambda access 65 - ; returned by generate-record, this function is called 66 - ; whenever a struct is accessed 67 - (case (length access) 68 - ;determine operation to perform 69 - ((0) vals) ; return list of values 70 - ((1) (struct-ref (car access))); search for value 71 - ((2) (update-record (car access) (cadr access))) 72 - (else #f))))) ; no other functions currently available 73 - 74 - ; keys are now stored in the closure; return the 75 - ; (generate-record) function to the user so she can 76 - ; call it to instantiate the defined struct. 77 - generate-record) 93 + (let* ([name (car body)] 94 + [fields (cdr body)] 95 + [typesym (gensym)] 96 + [types (map extract-type fields)]) 97 + (append (emit-pred name typesym) 98 + (emit-def name types) 99 + (emit-gen name types typesym fields) 100 + (reduce-fields name 0 fields))))