Add missing primitive implementation for the plain interpreter.
;; 13 April 2006, 0700 - 0840
(require (lib "match.ss")
(lib "pretty.ss")
(lib "1.ss" "srfi")
(lib "9.ss" "srfi"))
(print-struct #t)
(define previous-inspector (current-inspector))
(current-inspector (make-inspector))
(define-record-type <trait>
(make-trait operator operands)
trait?
(operator trait-operator)
(operands trait-operands))
(current-inspector previous-inspector)
(define (simple-trait patterns search-proc)
(make-trait 'simple (list patterns search-proc)))
(define (sum-trait traits)
(make-trait 'sum traits))
(define (override-trait traits-in-derived-to-base-order)
(make-trait 'override traits-in-derived-to-base-order))
(define (rename-trait t mapping mapping-proc)
(make-trait 'rename (list t mapping mapping-proc)))
(define (subtract-trait t patterns search-proc)
(make-trait 'subtract (list t patterns search-proc)))
(define-syntax trait*
(syntax-rules (+ / @ - = ^)
((_ (+ t ...)) (sum-trait (list (trait-expr t) ...)))
((_ (/ t ...)) (override-trait (list (trait-expr t) ...)))
((_ (@ t (new old) ...)) (rename-trait (trait-expr t)
'((new old) ...)
(lambda (self-and-args)
(match self-and-args
(new (list . old)) ...
(_ self-and-args)))))
((_ (- t pattern ...)) (subtract-trait (trait-expr t)
'(pattern ...)
(lambda (self-and-args)
(match self-and-args
(pattern #t) ...
(_ #f)))))
((_ (= expr)) expr)
((_ (^ pattern body ...)) (trait* (((self . pattern) body ...))))
((_ ((pattern body ...) ...)) (simple-trait '(pattern ...)
(lambda (self-and-args)
(match self-and-args
(pattern (lambda () (trait-expr body) ...))
...
(_ #f)))))
((_ var) var)))
(define-syntax trait-expr
(syntax-rules (quote let if)
((_ #(item ...))
(trait* (item ...)))
((_ (quote v))
(quote v))
((_ (let ((pattern expr) ...) body ...))
(trait-expr (let dummy ((pattern expr) ...) body ...)))
((_ (let loop ((pattern expr) ...) body ...))
(trait-expr (#(((loop pattern ...) body ...))
expr ...)))
((_ (receiver arg ...))
(traits-send (trait-expr receiver) (list (trait-expr arg) ...)))
((_ other)
other)))
(define-syntax define-trait
(syntax-rules ()
((_ name traitbody) (define name (trait-expr traitbody)))))
(define (search-trait trait self-and-args)
(let walk ((trait trait))
(let ((operands (trait-operands trait)))
(case (trait-operator trait)
((simple) ((cadr operands) self-and-args))
((sum) (let ((candidates (filter-map walk operands)))
(cond
((null? candidates) #f)
((pair? (cdr candidates)) 'conflict)
(else (car candidates)))))
((override) (let loop ((operands operands))
(cond
((null? operands) #f)
((walk (car operands)))
(else (loop (cdr operands))))))
((rename) (let ((new-self-and-args ((caddr operands) self-and-args)))
(search-trait (car operands) new-self-and-args)))
((subtract) (if ((caddr operands) self-and-args)
#f
(walk (car operands))))
(else (error "Bad trait operator" (trait-operator trait)))))))
(define (traits-for o)
(cond
((trait? o) o)
((number? o) <number>)
((string? o) <string>)
((symbol? o) <symbol>)
((boolean? o) <boolean>)
((pair? o) <scheme-pair>)
((null? o) <nil>)
((procedure? o) (simple-trait '(any) (lambda (self-and-args) (lambda () (apply o (cdr self-and-args))))))))
(define (invoke-method traits self args)
(let ((method (search-trait traits (cons self args))))
(cond
((procedure? method) (method))
((not method) (error "Does not understand" args self))
((eq? method 'conflict) (error "Method conflict" args self))
(else (error "Unknown search-trait result" method args self)))))
(define (lookup-method self args)
(let ((method (search-trait self (cons self args))))
(and (procedure? method)
method)))
(define (traits-send o args)
(invoke-method (traits-for o) o args))
(define-trait <extendable>
#(((self 'extend-with trait) #(/ trait (self 'species)))))
(define-trait <sequenceable>
#(((self 'map f) (self 'cons (f (self 'first)) ((self 'rest) 'map f)))
((self 'foldl f 'with seed) ((self 'rest) 'foldl f 'with (f (self 'first) seed)))
((self 'foldr f 'with seed) (f (self 'first) ((self 'rest) 'foldr f 'with seed)))))
(define-trait <consable>
#(((self 'cons f r) (self 'extend-with #(((self 'first) f)
((self 'rest) r)
((self 'empty?) #f))))))
(define-trait <empty-sequenceable>
#(((self 'map f) self)
((self 'foldl f 'with seed) seed)
((self 'foldr f 'with seed) seed)
((self 'empty?) #t)))
(define-trait <boolean>
#(((self 'ifTrue t) #(= (if self (trait-expr (t)) #f)))
((self 'ifFalse f) #(= (if self #f (trait-expr (f)))))
((self 'ifTrue t 'ifFalse f) #(= (if self (trait-expr (t)) (trait-expr (f)))))))
(define tmap (trait-expr #(((self f seq)
((seq 'empty?)
'ifTrue #(^() seq)
'ifFalse #(^() (seq 'cons (f (seq 'first)) (self f (seq 'rest)))))))))
(define-syntax define-prototype
(syntax-rules ()
((_ n traitbody) (define n (trait-expr #(/ #(((self 'species) n)
((self 'name) 'n))
traitbody))))))
(define-prototype <nil> <empty-sequenceable>)
(define-prototype <pair> #(+ <sequenceable> <consable> <extendable>))
(define-prototype <scheme-pair> (<pair> 'extend-with #(((self 'first) #(= (car self)))
((self 'rest) #(= (cdr self)))
((self 'empty?) #f)
((self 'cons f r) #(= (cons f r))))))
(define (kons f r)
(trait-expr (<pair> 'cons f r)))
(define (liszt . l)
(fold-right kons <nil> l))
(define (expand-series exp)
(pretty-print exp)(newline)
(let loop ((stx (expand-once exp)))
(pretty-print (syntax-object->datum stx))(newline)
(let ((next (expand-once stx)))
(when (not (equal? (syntax-object->datum stx)
(syntax-object->datum next)))
(loop next)))))