ADDED lib/fn-struct.scm Index: lib/fn-struct.scm ================================================================== --- lib/fn-struct.scm +++ lib/fn-struct.scm @@ -0,0 +1,77 @@ +; [ʞ] fn-struct.scm +; ~ lexi hale +; © affero general public license +; > (load "lib/struct.scm") +; +; generates immutable, relatively efficient structs. declare +; a struct type x with +; (define x (struct 'field1 'field2) +; create a record y of that type with +; (define y (x 123 456)) +; access field1 of record y with +; (y 'field1) +; update field2 of record y with +; (y 'field2 123) → new record (field1 = 123; field2 = 123) +; +; this unit also includes a few utility function that +; chicken scheme conveniently "forgot." i apologize for +; the implementation of (list-head). i was very tired. + +; return a sub-list of lst up to ct (inverse of list-tail) +(define (list-head lst ct) + (let* ([reverse-lst (reverse lst)] + [idx (- (length lst) (+ 1 ct))]) + (reverse (list-tail reverse-lst idx)))) + ; i'm not proud of this + +; search for the first occurence of `term` in list lst. +; equal? is used by default; an alternate predicate may +; be passed after `term` +(define (member-index lst term . opt) + (let ([predicate (if (eq? '() opt) equal? + (car opt))]) + (define (search idx l) + (if (eq? l '()) #f + (if (predicate (car l) term) idx + (search (+ 1 idx) (cdr l))))) + (search 0 lst))) + +; generate a new struct type and return it as a function +; that may be called to instantiate that type. +(define (struct . keys) + (define (generate-record . vals) + ; the function returned by a (struct) call and called + ; to generate a new struct by functional-update syntax + (define (struct-ref key) + ; searches the struct for the named key and if found + ; return its index, otherwise return #f + (let ([query-idx (member-index keys key)]) + (if (eq? #f query-idx) #f + (list-ref vals query-idx)))) + (define (update-record key val) + ; return a new version of this construct with the same + ; field names and values except for { key = val } + (let* ([field-idx (member-index keys key)] + [new-tail (list-tail vals (+ 1 field-idx))] + [new-head (list-head vals (- field-idx 1))]) + (apply generate-record (append new-head (list val) new-tail)))) + + ; are values specified for every field and no more? + ; TODO: consider loosening the restriction - could + ; there be some use to allowing the used to add fields + ; only accessible through the record->list facility? + (if (not (= (length vals) (length keys))) #f + (lambda access + ; returned by generate-record, this function is called + ; whenever a struct is accessed + (case (length access) + ;determine operation to perform + ((0) vals) ; return list of values + ((1) (struct-ref (car access))); search for value + ((2) (update-record (car access) (cadr access))) + (else #f))))) ; no other functions currently available + + ; keys are now stored in the closure; return the + ; (generate-record) function to the user so she can + ; call it to instantiate the defined struct. + generate-record) ADDED lib/select.scm Index: lib/select.scm ================================================================== --- lib/select.scm +++ lib/select.scm @@ -0,0 +1,33 @@ +; [ʞ] select.scm +; ~ lexi hale +; © CC0 / public domain +; > (include "lisp-macro.scm") +; (include "select.scm") +; ? a reimplementation of (case) that lets you +; specify your own evaluator function. same syntax, +; except the expression to evaluate is preceeded by +; a predicate function +; = (select equal? "weed" +; ("weed" 420) +; ("sex" 69) +; (else 42069) + +(define-macro (select . body) + (let* ([eqfn (list-ref body 0)] + [expr (list-ref body 1)] + [cases (cddr body)] + [result (gensym)]) + (define (make-cond-entry case) + (let ([case-expr (car case)] + [func (cdr case)]) + (if (eqv? case-expr 'else) (cons #t func) + (cons (list eqfn result case-expr) func)))) + (define cond-entries (map make-cond-entry cases)) + `(let ([,result ,expr]) (cond ,@cond-entries)))) + +(define-macro (maybe . body) + (let (( result (gensym) )) + `(let (( ,result ,(cadr body) )) + (if ,result (let (( ,(car body) ,result )) + ,(cddr body)) + #f)))) Index: lib/struct.scm ================================================================== --- lib/struct.scm +++ lib/struct.scm @@ -1,77 +1,100 @@ ; [ʞ] struct.scm ; ~ lexi hale -; © affero general public license -; > (load "lib/struct.scm") -; -; generates immutable, relatively efficient structs. declare -; a struct type x with -; (define x (struct 'field1 'field2) -; create a record y of that type with -; (define y (x 123 456)) -; access field1 of record y with -; (y 'field1) -; update field2 of record y with -; (y 'field2 123) → new record (field1 = 123; field2 = 123) -; -; this unit also includes a few utility function that -; chicken scheme conveniently "forgot." i apologize for -; the implementation of (list-head). i was very tired. +; $ csc -X fail.scm … +; © affero gpl v3 +; > (include "lisp-macro.scm") +; ? a typed struct mechanism for scheme, because the +; srfi ones suck ass and don't support FRU syntax. +; X (structure user (name . string) +; (age . integer) +; (pw . string) +; gecos) +; (define stacy (user name: "stacy" +; age: 26 +; pw: "swordfish")) +; (if (user? stacy) (user.name stacy)) +; (define oldstacy (user stacy age: 69)) +; (user.name oldstacy) +; (user.age oldstacy) + +(include "lisp-macro.scm") + +(import (chicken pretty-print) + (chicken keyword)) + +(begin-for-syntax (import (chicken keyword))) + ; i cannot believe this worked + +(define-macro (structure . body) + (define (uniq lst) + (define (in? x l) + (if (null? l) #f + (if (eqv? x (car l)) #t + (in? x (cdr l))))) + (define (loop acc hd) + (if (null? hd) acc + (if (in? (car hd) acc) (loop acc (cdr hd)) + (loop (cons (car hd) acc) (cdr hd))))) + (loop '() lst)) + + (define (symsuf sym . suffix) + (string->symbol (apply string-append (cons (symbol->string sym) suffix)))) + + (define (emit-field sname idx f) + (let* ([prop (cond ((symbol? f) (cons f 'any)) + ((pair? f) f))] + [name (car prop)] + [type (cdr prop)] + [fn (symsuf sname "." (symbol->string name))]) + `(begin + (: ,fn ((pair symbol vector) --> ,type)) + (define (,fn struct) + (if (,(symsuf sname "?") struct) (vector-ref (cdr struct) ,idx) + (error ,(string-append "argument is not of type " (symbol->string sname)))))))) + + (define (reduce-fields sname idx fields) + (if (null? fields) '() + (cons (emit-field sname idx (car fields)) + (reduce-fields sname (+ 1 idx) (cdr fields))))) + + (define (emit-pred name typesym) + (let ([fn (symsuf name "?")]) + `(begin (: ,fn (any --> boolean)) + (define (,fn candidate) (and (pair? candidate) + (eq? (quote ,typesym) (car candidate)) + (vector? (cdr candidate))))))) + (define (extract-type field) + (cond ((symbol? field) 'any) + ((pair? field) (cdr field)))) -; return a sub-list of lst up to ct (inverse of list-tail) -(define (list-head lst ct) - (let* ([reverse-lst (reverse lst)] - [idx (- (length lst) (+ 1 ct))]) - (reverse (list-tail reverse-lst idx)))) - ; i'm not proud of this + (define (emit-def name types) + `((define-type ,name (pair symbol (vector ,@types))))) -; search for the first occurence of `term` in list lst. -; equal? is used by default; an alternate predicate may -; be passed after `term` -(define (member-index lst term . opt) - (let ([predicate (if (eq? '() opt) equal? - (car opt))]) - (define (search idx l) - (if (eq? l '()) #f - (if (predicate (car l) term) idx - (search (+ 1 idx) (cdr l))))) - (search 0 lst))) + (define (emit-gen name types typesym fields) + (define (fld-get idx fld) + (let ([name (if (symbol? fld) fld (car fld))]) + `(get-keyword ,(string->keyword (symbol->string name)) spec + (lambda() (safe-vector-ref basis ,idx))))) + (define (reduce-flds idx flds) + (if (null? flds) '() + (cons (fld-get idx (car flds)) + (reduce-flds (+ 1 idx) (cdr flds))))) + `((: ,name (#!rest (or symbol ,@(uniq types)) --> ,name )) + (define (,name . args) + (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") + (vector-ref v i))) + (let* ([basis (if (,(symsuf name "?") (car args)) (cdar args) '())] + [spec (if (null? basis) args (cdr args))]) + (cons (quote ,typesym) + (vector ,@(reduce-flds 0 fields) -; generate a new struct type and return it as a function -; that may be called to instantiate that type. -(define (struct . keys) - (define (generate-record . vals) - ; the function returned by a (struct) call and called - ; to generate a new struct by functional-update syntax - (define (struct-ref key) - ; searches the struct for the named key and if found - ; return its index, otherwise return #f - (let ([query-idx (member-index keys key)]) - (if (eq? #f query-idx) #f - (list-ref vals query-idx)))) - (define (update-record key val) - ; return a new version of this construct with the same - ; field names and values except for { key = val } - (let* ([field-idx (member-index keys key)] - [new-tail (list-tail vals (+ 1 field-idx))] - [new-head (list-head vals (- field-idx 1))]) - (apply generate-record (append new-head (list val) new-tail)))) + )))))) - ; are values specified for every field and no more? - ; TODO: consider loosening the restriction - could - ; there be some use to allowing the used to add fields - ; only accessible through the record->list facility? - (if (not (= (length vals) (length keys))) #f - (lambda access - ; returned by generate-record, this function is called - ; whenever a struct is accessed - (case (length access) - ;determine operation to perform - ((0) vals) ; return list of values - ((1) (struct-ref (car access))); search for value - ((2) (update-record (car access) (cadr access))) - (else #f))))) ; no other functions currently available - - ; keys are now stored in the closure; return the - ; (generate-record) function to the user so she can - ; call it to instantiate the defined struct. - generate-record) + (let* ([name (car body)] + [fields (cdr body)] + [typesym (gensym)] + [types (map extract-type fields)]) + (append (emit-pred name typesym) + (emit-def name types) + (emit-gen name types typesym fields) + (reduce-fields name 0 fields))))