Differences From
Artifact [06f94eb978]:
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))))