;;;---------------------------------------------------------------------- ;;; A datatype macro for Scheme: (define make-datatype-transformer (lambda (cons-prefix cons-suffix recycle-prefix recycle-suffix pred-prefix pred-suffix case-prefix case-suffix) (letrec ([as-string (lambda (x) (cond [(identifier? x) (as-string (syntax-object->datum x))] [(symbol? x) (symbol->string x)] [(string? x) x] [else (error 'datatype "cannot construct an identifier using ~s" x)]))] [construct-id (lambda (context . parts) (datum->syntax-object context (string->symbol (apply string-append (map as-string parts)))))]) (lambda (x) (syntax-case x () [(_ ?name (?variant ?field ...) ...) (and (identifier? (syntax ?name)) (andmap identifier? (syntax (?variant ...)))) (with-syntax ([(?constructor ...) (map (lambda (variant) (construct-id (syntax ?name) cons-prefix variant cons-suffix)) (syntax (?variant ...)))] [(?recycler ...) (map (lambda (variant) (construct-id (syntax ?name) recycle-prefix variant recycle-suffix)) (syntax (?variant ...)))] [?datatype-predicate (construct-id (syntax ?name) pred-prefix (syntax ?name) pred-suffix)] [?case (construct-id (syntax ?name) case-prefix (syntax ?name) case-suffix)] [(?field-count ...) (map (lambda (fields) (datum->syntax-object (syntax ?name) (length fields))) (syntax ((?field ...) ...)))] [(((?field-name ?predicate) ...) ...) (map (lambda (fields) (map (lambda (field) (syntax-case field () [(?field-name ?predicate) (identifier? (syntax ?field-name)) field] [?field-name (identifier? (syntax ?field-name)) (syntax (?field-name (lambda (x) #t)))])) fields)) (syntax ((?field ...) ...)))]) (syntax (begin (begin (define ?constructor (lambda (?field-name ...) (if (and (?predicate ?field-name) ...) (vector '?name '?variant ?field-name ...) (error '?constructor "invalid argument types")))) (define-syntax ?recycler (let ([fields (list '?field-name ...)]) (letrec ([lookup-index (lambda (target source start) (cond [(null? source) (error '?recycler "unrecognized field name: ~a" source)] [(eqv? target (car source)) start] [else (lookup-index target (cdr source) (+ start 1))]))]) (lambda (x) (syntax-case x () [(__ ??old [??delta-field ??delta-value] (... ...)) (with-syntax ([(??delta-index (... ...)) (map (lambda (field) (datum->syntax-object (syntax __) (lookup-index (syntax-object->datum field) fields 2))) (syntax (??delta-field (... ...))))]) (syntax (let ([new ??old]) (if (and (vector? new) (= (vector-length new) (+ ?field-count 2))) (begin (vector-set! new 0 '?name) (vector-set! new 1 '?variant) (vector-set! new ??delta-index ??delta-value) (... ...) new) (error '?recycler "~s cannot be recycled as a ~a" new '?variant)))))])))))) ... (define ?datatype-predicate (lambda (x) (and (vector? x) (>= (vector-length x) 2) (eqv? (vector-ref x 0) '?name)))) (define ?name (list (cons '?variant '?field-count) ...)) (define-syntax ?case (letrec ([build-indices (lambda (context variant-name vars table) (let ([entry (assoc variant-name table)]) (if entry (let ([field-count (cdr entry)]) (if (= field-count (length vars)) (make-range context 2 (+ field-count 2)) (error '?case "incorrect number of fields in ~a" variant-name))) (error '?case "~a is not a variant of ~a" variant-name (syntax-object->datum (syntax ?name))))))] [make-range (lambda (context start end) (cond [(>= start end) '()] [else (cons (datum->syntax-object context start) (make-range context (+ start 1) end))]))]) (let ([variant-table (list (cons '?variant '?field-count) ...)]) (lambda (x) (syntax-case x () [(__ ??exp ??clause0 ??clause1 (... ...)) (with-syntax ([??body (let caseloop ([clause0 (syntax ??clause0)] [others (syntax (??clause1 (... ...)))]) (cond [(null? others) (syntax-case clause0 (else) [(else ??body (... ...)) (syntax (begin ??body (... ...)))] [((??variant ??var (... ...)) ??body (... ...)) (with-syntax ([(??index (... ...)) (build-indices (syntax ?case) (syntax-object->datum (syntax ??variant)) (syntax (??var (... ...))) variant-table)]) (syntax (if (eqv? variant-tag '??variant) (let ([??var (vector-ref case-val ??index)] (... ...)) ??body (... ...)) (error '?case "no matching clause for ~s" case-val))))])] [else (syntax-case clause0 (else) [((??variant ??var (... ...)) ??body (... ...)) (with-syntax ([??rest (caseloop (car others) (cdr others))] [(??index (... ...)) (build-indices (syntax ?case) (syntax-object->datum (syntax ??variant)) (syntax (??var (... ...))) variant-table)]) (syntax (if (eqv? (vector-ref case-val 1) '??variant) (let ([??var (vector-ref case-val ??index)] (... ...)) ??body (... ...)) ??rest)))])]))]) (syntax (let ([case-val ??exp]) (if (?datatype-predicate case-val) (let ([variant-tag (vector-ref case-val 1)]) ??body) (error '?case "~s is not a ~a" case-val '?name)))))]))))))))]))))) (define-syntax type-case (letrec ([build-indices (lambda (name context variant-name vars table) (let ([entry (assoc variant-name table)]) (if entry (let ([field-count (cdr entry)]) (if (= field-count (length vars)) (make-range context 2 (+ field-count 2)) (error 'type-case "incorrect number of fields in ~a" variant-name))) (error 'type-case "~a is not a variant of ~a" variant-name (syntax-object->datum name)))))] [make-range (lambda (context start end) (cond [(>= start end) '()] [else (cons (datum->syntax-object context start) (make-range context (+ start 1) end))]))]) (lambda (x) (syntax-case x () [(_ ?type ?exp ?clause0 ?clause1 ...) (identifier? (syntax ?type)) (let ([variant-table (top-level-value (syntax-object->datum (syntax ?type)))]) (with-syntax ([?datatype-predicate (datum->syntax-object (syntax ?type) (string->symbol (string-append (symbol->string (syntax-object->datum (syntax ?type))) "?")))] [?body (let caseloop ([clause0 (syntax ?clause0)] [others (syntax (?clause1 ...))]) (cond [(null? others) (syntax-case clause0 (else) [(else ?body ...) (syntax (begin ?body ...))] [((?variant ?var ...) ?body ...) (with-syntax ([(?index ...) (build-indices (syntax ?type) (syntax _) (syntax-object->datum (syntax ?variant)) (syntax (?var ...)) variant-table)]) (syntax (if (eqv? variant-tag '?variant) (let ([?var (vector-ref case-val ?index)] ...) ?body ...) (error 'type-case "no matching clause for ~s" case-val))))])] [else (syntax-case clause0 (else) [((?variant ?var ...) ?body ...) (with-syntax ([?rest (caseloop (car others) (cdr others))] [(?index ...) (build-indices (syntax ?type) (syntax _) (syntax-object->datum (syntax ?variant)) (syntax (?var ...)) variant-table)]) (syntax (if (eqv? (vector-ref case-val 1) '?variant) (let ([?var (vector-ref case-val ?index)] ...) ?body ...) ?rest)))])]))]) (syntax (let ([case-val ?exp]) (if (?datatype-predicate case-val) (let ([variant-tag (vector-ref case-val 1)]) ?body) (error 'type-case "~s is not a ~a" case-val '?type))))))])))) (define-syntax define-datatype (make-datatype-transformer "make-" "" "recycle-as-" "" "" "?" "" "-case"))