Skip to content

Instantly share code, notes, and snippets.

@okuoku

okuoku/out.scm Secret

Created August 24, 2016 17:17
Show Gist options
  • Save okuoku/9152a66a1051a68b2677bfbe7b3650b0 to your computer and use it in GitHub Desktop.
Save okuoku/9152a66a1051a68b2677bfbe7b3650b0 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
out.scm
((begin
(define-syntax
case-lambda
(syntax-rules
()
((_ (frm code ...)) (lambda frm code ...))
((_ clauses ...) (%%gen-case-lambda-dispatch () () () clauses ...))))
(define-syntax
%%emit-case-lambda-body
(syntax-rules
()
((_ () () () count x) (error "case-lambda: unmatched" count))
((_ (n ...) (#t ...) ((frm body ...)) count x) (let ((frm x)) body ...))
((_ (n nn ...) (pred pp ...) ((frm body ...) next ...) count x)
(if (pred count n)
(apply (lambda frm body ...) x)
(%%emit-case-lambda-body (nn ...) (pp ...) (next ...) count x)))))
(define-syntax
%gen-case-lambda-dotted-reverse-quote
(syntax-rules
()
((_ acc (frm a . d))
(%gen-case-lambda-dotted-reverse-quote (frm . acc) (a . d)))
((_ acc (frm . rest)) '(frm . acc))))
(define-syntax
%%gen-case-lambda-dispatch
(syntax-rules
()
((_ n pred clauses)
(lambda x
(let ((count (length x)))
(%%emit-case-lambda-body n pred clauses count x))))
((_ (n ...) (pred ...) (clauses ...) ((frms ...) . code) next ...)
(let ((nn (length '(frms ...))))
(%%gen-case-lambda-dispatch
(n ... nn)
(pred ... =)
(clauses ... ((frms ...) . code))
next
...)))
((_ (n ...) (pred ...) (clauses ...) ((frms . rest) . code) next ...)
(let ((nn (length (%gen-case-lambda-dotted-reverse-quote
()
(frms . rest)))))
(%%gen-case-lambda-dispatch
(n ... nn)
(pred ... >=)
(clauses ... ((frms . rest) . code))
next
...)))
((_ (n ...) (pred ...) (clauses ...) (frms . code) next ...)
(%%gen-case-lambda-dispatch
(n ... #t)
(pred ... #t)
(clauses ... (frms . code))
next
...)))))
(begin
(define %%my-eof-object (let ((p (open-input-string ""))) (read p)))
(define (eof-object) %%my-eof-object)
(define (flush-output-port p) 'do-nothing)
(define bytevector? u8vector?)
(define bytevector u8vector)
(define bytevector-append u8vector-append)
(define bytevector-copy u8vector-copy)
(define bytevector-length u8vector-length)
(define bytevector-u8-ref u8vector-ref)
(define bytevector-u8-set! u8vector-set!)
(define make-bytevector make-u8vector)
(define bytevector-copy!
(case-lambda
((to at from) (bytevector-copy! to at from 0))
((to at from start)
(let ((flen (bytevector-length from)) (tlen (bytevector-length to)))
(let ((fmaxcopysize (- flen start)) (tmaxcopysize (- tlen at)))
(bytevector-copy!
to
at
from
start
(+ start (min fmaxcopysize tmaxcopysize))))))
((to at from start end) (subu8vector-move! from start end to at))))
(define (%utf8->string u8)
(define len (u8vector-length u8))
(define (complain) (error "Illegal utf8 sequence" u8))
(call-with-output-string
'()
(lambda (p)
(let loop ((idx 0))
(define rest (- len idx))
(cond ((= idx len) p)
(else
(let ((c0 (u8vector-ref u8 idx)))
(cond ((< c0 128)
(write-char (integer->char c0) p)
(loop (+ 1 idx)))
((< c0 224)
(if (< rest 1) (complain))
(let* ((c1 (u8vector-ref u8 (+ 1 idx)))
(i (bitwise-ior
(arithmetic-shift (bitwise-and 31 c0) 6)
(bitwise-and 63 c1))))
(write-char (integer->char i) p))
(loop (+ 2 idx)))
((< c0 240)
(if (< rest 2) (complain))
(let* ((c1 (u8vector-ref u8 (+ 1 idx)))
(c2 (u8vector-ref u8 (+ 2 idx)))
(i (bitwise-ior
(arithmetic-shift (bitwise-and 15 c0) 12)
(arithmetic-shift (bitwise-and 63 c1) 6)
(bitwise-and 63 c2))))
(write-char (integer->char i) p))
(loop (+ 3 idx)))
((< c0 245)
(if (< rest 3) (complain))
(let* ((c1 (u8vector-ref u8 (+ 1 idx)))
(c2 (u8vector-ref u8 (+ 2 idx)))
(c3 (u8vector-ref u8 (+ 3 idx)))
(i (bitwise-ior
(arithmetic-shift (bitwise-and 7 c0) 18)
(arithmetic-shift (bitwise-and 63 c1) 12)
(arithmetic-shift (bitwise-and 63 c2) 6)
c3)))
(write-char (integer->char i) p))
(loop (+ 4 idx)))
(else (complain))))))))))
(define utf8->string
(case-lambda
((u8) (%utf8->string u8))
((u8 start) (%utf8->string (subu8vector u8 start (u8vector-length u8))))
((u8 start end) (%utf8->string (subu8vector u8 start end)))))
(define (%string->utf8 str)
(define len (string-length str))
(call-with-output-u8vector
'()
(lambda (p)
(let loop ((idx 0))
(cond ((= idx len) p)
(else
(let ((i (char->integer (string-ref str idx))))
(cond ((< i 128) (write-u8 i p))
((< i 2048)
(let ((c0 (bitwise-ior
192
(bitwise-and 31 (arithmetic-shift i -6))))
(c1 (bitwise-ior 128 (bitwise-and 63 i))))
(write-u8 c0 p)
(write-u8 c1 p)))
((< i 65536)
(let ((c0 (bitwise-ior
224
(bitwise-and
15
(arithmetic-shift i -12))))
(c1 (bitwise-ior
128
(bitwise-and 63 (arithmetic-shift i -6))))
(c2 (bitwise-ior 128 (bitwise-and 63 i))))
(write-u8 c0 p)
(write-u8 c1 p)
(write-u8 c2 p)))
((< i 1114112)
(let ((c0 (bitwise-ior
240
(bitwise-and 7 (arithmetic-shift i -18))))
(c1 (bitwise-ior
128
(bitwise-and
63
(arithmetic-shift i -12))))
(c2 (bitwise-ior
128
(bitwise-and 63 (arithmetic-shift i -6))))
(c3 (bitwise-ior 128 (bitwise-and 63 i))))
(write-u8 c0 p)
(write-u8 c1 p)
(write-u8 c2 p)
(write-u8 c3 p)))
(else (error "Invalid character" i str))))
(loop (+ 1 idx))))))))
(define string->utf8
(case-lambda
((str) (%string->utf8 str))
((str start) (%string->utf8 (substring str start (string-length str))))
((str start end) (%string->utf8 (substring str start end)))))
(define-syntax
define-record-type
(syntax-rules
()
((_ name (ctr ctr-name ...) pred? flds ...)
(begin
(define name (list 'table-type))
(define (ctr ctr-name ...)
(define theRecord (make-table))
(table-set! theRecord '%%yunifake-record-type name)
(table-set! theRecord 'ctr-name ctr-name)
...
theRecord)
(define (pred? obj)
(and (table? obj)
(eq? name (table-ref obj '%%yunifake-record-type))))
(%define-record-type-fields pred? flds)
...))))
(define-syntax
%define-record-type-fields
(syntax-rules
()
((_ pred? (field-name accessor))
(begin
(define (accessor obj)
(cond ((pred? obj) (table-ref obj 'field-name))
(else (error "Unexpected object" pred? obj))))))
((_ pred? (field-name accessor setter))
(begin
(define (setter obj val)
(cond ((pred? obj) (table-set! obj 'field-name val))
(else (error "Unexpected object" pred? obj))))
(%define-record-type-fields pred? (field-name accessor))))))
(define-syntax
when
(syntax-rules () ((_ pred code ...) (cond (pred code ...)))))
(define-syntax
unless
(syntax-rules () ((_ pred code ...) (cond ((not pred) code ...))))))
(begin
(define %%%export-testeval~24 #f)
(define %%%export-failure?~25 #f)
(define %%%export-failure->string~26 #f)
(let ()
(define failure-header (list "Yuni testing failure"))
(define (failure? x) (not (eq? #t x)))
(define (failure->string f)
(let ((p (open-output-string))) (write f p) (get-output-string p)))
(define (testeval form lib*)
(define (libname lib)
(if (pair? lib)
(case (car lib)
((rename except only) (libname (cadr lib)))
(else lib))))
(define (assert-for-library lib)
(guard (c (#t c)) (begin (eval 123 (environment lib)) #f)))
(define (assert-for-libraries libs*)
(and (pair? libs*)
(or (assert-for-library (libname (car libs*)))
(assert-for-libraries (cdr libs*)))))
(let ((libresult (assert-for-libraries lib*)))
(if libresult
(values #f libresult)
(guard (c (#t (values #f c)))
(let ((ret (eval form (apply environment lib*))))
(values ret #t))))))
(set! %%%export-testeval~24 testeval)
(set! %%%export-failure?~25 failure?)
(set! %%%export-failure->string~26 failure->string)))
(begin
(begin
(define-syntax
seq
(syntax-rules
(=>)
((_ clauses ... => error-handler) (seq => error-handler clauses ...))
((_ => error-handler clauses ...)
(let ((err error-handler)) (%seq/clauses err clauses ...)))
((_ otherwise ...) (seq => (lambda x (if #f #f)) otherwise ...))))
(define-syntax
%seq/clauses
(syntax-rules
(=>)
((_ err (=> something ...) anything ...)
(%seq/splitL
()
()
(something ...)
(err (%seq/clauses err anything ...))))
((_ err normal-form next-form ...)
(begin normal-form (%seq/clauses err next-form ...)))
((_ err) (begin))))
(define-syntax
%seq/splitL
(syntax-rules
(=>)
((_ cur (acc ...) (item => something ...) n)
(%seq/splitR cur (acc ... item) () (something ...) n))
((_ cur (acc ...) (s0 s1 ...) n)
(%seq/splitL cur (acc ... s0) (s1 ...) n))))
(define-syntax
%seq/splitR
(syntax-rules
(=>)
((_ (cur ...) L R () (err next)) (%seq/emit err (cur ... (L R)) next))
((_ (cur ...) L (acc ...) (item => something ...) n)
(%seq/splitL (cur ... (L (acc ... item))) () (something ...) n))
((_ cur L (acc ...) (something anything ...) n)
(%seq/splitR cur L (acc ... something) (anything ...) n))))
(define-syntax
%seq/emit
(syntax-rules
()
((_ err () next) next)
((_ err ((q0 c0) qc1 ...) next)
(%seq/gen err q0 c0 (%seq/emit err (qc1 ...) next)))))
(define-syntax
%seq/gen
(syntax-rules
'unquote
((_ err ('something q0 ...) c0 next)
(%seq/call 'err something (q0 ...) c0 next))
((_ err (,something q0 ...) c0 next)
(%seq/call err something (q0 ...) c0 next))
((_ err (anything ...) c0 next)
(%seq/call err #f (anything ...) c0 next))))
(define-syntax
%seq/call
(syntax-rules
()
((_ err id (call ...) recv next)
(call ... (%seq/gencallback err id () () recv next)))))
(define-syntax
%seq/gencallback
(syntax-rules
()
((_ err id (names ...) (checks ...) () next)
(lambda (names ...) (if (and checks ...) next (err id names ...))))
((_ err id (names ...) (checks ...) ((checker name) obj ...) next)
(%seq/gencallback
err
id
(names ... name)
(checks ... (checker name))
(obj ...)
next))
((_ err id (names ...) (checks ...) ((name) obj ...) next)
(%seq/gencallback
err
id
(names ... name)
(checks ... name)
(obj ...)
next))
((_ err id (names ...) checks (name obj ...) next)
(%seq/gencallback err id (names ... name) checks (obj ...) next))))
(define (apply/async limit proc param callback)
(define len (length param))
(define input (list->vector param))
(define v (make-vector len #f))
(define count 0)
(define jobs 0)
(define count-finish 0)
(define abort? #f)
(define (job-finish) (set! jobs (- jobs 1)))
(define (last-job?)
(set! count-finish (+ 1 count-finish))
(= count-finish len))
(define (enqueue)
(if abort?
(if (last-job?) (callback (vector->list v)) (next))
(let* ((par (vector-ref input count))
(idx count)
(cb (lambda x
(vector-set! v idx x)
(job-finish)
(if (last-job?)
(callback (vector->list v))
(next)))))
(set! jobs (+ jobs 1))
(let ((r (if (list? par)
(apply proc (append par (list cb)))
(proc par cb))))
(unless r (set! jobs 0) (set! abort? #t))))))
(define (next)
(unless (or (= count len) (and limit (= jobs limit)))
(enqueue)
(set! count (+ count 1))
(next))
(not abort?))
(next))))
(begin
(define %%%export-miniobj-rnrs-ref-error~28 #f)
(define %%%export-miniobj-rnrs-set!-error~29 #f)
(let ()
(define (miniobj-rnrs-ref-error obj slot)
(error "miniobj: unsupported object" (list obj slot)))
(define (miniobj-rnrs-set!-error obj slot value)
(error "miniobj: unsupported object" (list obj slot value)))
(set! %%%export-miniobj-rnrs-ref-error~28 miniobj-rnrs-ref-error)
(set! %%%export-miniobj-rnrs-set!-error~29 miniobj-rnrs-set!-error)))
(begin
(define %%%export-make-simple-struct~30 #f)
(define %%%export-simple-struct-name~31 #f)
(define %%%export-simple-struct-ref~32 #f)
(define %%%export-simple-struct-set!~33 #f)
(define %%%export-simple-struct?~34 #f)
(let ()
(define-record-type
<yuni-simple-struct>
(%make-simple-struct0 name object)
simple-struct?
(name simple-struct-name)
(object %simple-struct-obj))
(define (simple-struct-ref obj idx)
(vector-ref (%simple-struct-obj obj) idx))
(define (simple-struct-set! obj idx v)
(vector-set! (%simple-struct-obj obj) idx v))
(define (make-simple-struct name len lis)
(%make-simple-struct0 name (list->vector lis)))
(set! %%%export-make-simple-struct~30 make-simple-struct)
(set! %%%export-simple-struct-name~31 simple-struct-name)
(set! %%%export-simple-struct-ref~32 simple-struct-ref)
(set! %%%export-simple-struct-set!~33 simple-struct-set!)
(set! %%%export-simple-struct?~34 simple-struct?)))
(begin
(define make-simple-struct %%%export-make-simple-struct~30)
(define simple-struct-name %%%export-simple-struct-name~31)
(define simple-struct-ref %%%export-simple-struct-ref~32)
(define simple-struct-set! %%%export-simple-struct-set!~33)
(define simple-struct? %%%export-simple-struct?~34)
(define (check? obj sym)
(and (simple-struct? obj) (eq? sym (simple-struct-name obj))))
(define (minitype? obj) (check? obj '*yuni-minitype*))
(define (minitype-obj? obj) (check? obj '*yuni-minitype-obj*))
(define (check-minitype obj)
(or (minitype? obj) (error "minitype needed" obj)))
(define (check-minitype-obj obj)
(or (minitype-obj? obj) (error "minitype-obj needed" obj)))
(define (minitype-slot obj) (check-minitype obj) (simple-struct-ref obj 1))
(define (minitype-obj-slot obj)
(check-minitype-obj obj)
(simple-struct-ref obj 1))
(define (minitype-obj-type obj)
(check-minitype-obj obj)
(simple-struct-ref obj 0))
(define (make-minitype name slots)
(make-simple-struct '*yuni-minitype* 2 (list name slots)))
(define (make-minitype-obj minitype)
(check-minitype minitype)
(lambda ()
(make-simple-struct
'*yuni-minitype-obj*
2
(list minitype (make-vector (length (minitype-slot minitype)))))))
(define (minitype-predicate obj minitype)
(check-minitype minitype)
(and (minitype-obj? obj) (eq? minitype (minitype-obj-type obj))))
(define (minitype-typeof obj)
(and (minitype-obj? obj) (minitype-obj-type obj)))
(define (scan-slot minitype slot)
(define (number cur rest)
(if (pair? rest)
(if (eq? (car rest) slot) cur (number (+ 1 cur) (cdr rest)))
#f))
(let ((slots (minitype-slot minitype))) (number 0 slots)))
(define (miniobj-minitype-typeof obj k)
(if (minitype-obj? obj) (minitype-obj-type obj) (k obj)))
(define (miniobj-minitype-typeof-error obj)
(error "unsupported object" obj))
(define (miniobj-minitype-ref obj slot k)
(if (minitype-obj? obj)
(vector-ref
(minitype-obj-slot obj)
(scan-slot (minitype-obj-type obj) slot))
(k obj slot)))
(define (miniobj-minitype-set! obj slot value k)
(if (minitype-obj? obj)
(vector-set!
(minitype-obj-slot obj)
(scan-slot (minitype-obj-type obj) slot)
value)
(k obj slot value)))
(define-syntax
define-minitype
(syntax-rules
()
((_ name spec) (define name (make-minitype 'name 'spec))))))
(begin
(define-minitype <minidispatch> (name func))
(define-minitype <minidispatch-obj> (minitype obj))
(define (baseref obj slot)
(define (complain obj slot) (error "Fatal error" obj slot))
(miniobj-minitype-ref obj slot complain))
(define (baseset! obj slot v)
(define (complain obj slot v) (error "Fatal error" obj slot))
(miniobj-minitype-set! obj slot v complain))
(define (minidispatch-obj? obj) (minitype-predicate obj <minidispatch-obj>))
(define (minidispatch-class? obj) (minitype-predicate obj <minidispatch>))
(define-syntax
define-minidispatch-class
(syntax-rules
()
((_ nam fun)
(define nam
(let ((obj ((make-minitype-obj <minidispatch>))))
(baseset! obj 'name 'nam)
(baseset! obj 'func fun)
obj)))))
(define (make-minidispatch-obj class param)
(unless (minidispatch-class? class)
(error "minidispatch class required" class))
(let ((obj ((make-minitype-obj <minidispatch-obj>))))
(baseset! obj 'minitype class)
(baseset! obj 'obj param)
obj))
(define (do-ref obj slot)
(let* ((typ (baseref obj 'minitype))
(func (baseref typ 'func))
(o (baseref obj 'obj)))
(func 'ref slot o)))
(define (do-set! obj slot value)
(let* ((typ (baseref obj 'minitype))
(func (baseref typ 'func))
(o (baseref obj 'obj)))
(func 'set! slot o value)))
(define (do-typeof obj) (define typ (baseref obj 'minitype)) typ)
(define (miniobj-minidispatch-aux obj)
(let* ((typ (baseref obj 'minitype)) (func (baseref typ 'func))) func))
(define (miniobj-minidispatch-ref obj slot k)
(if (minidispatch-obj? obj) (do-ref obj slot) (k obj slot)))
(define (miniobj-minidispatch-set! obj slot value k)
(if (minidispatch-obj? obj) (do-set! obj slot value) (k obj slot value)))
(define (miniobj-minidispatch-typeof obj k)
(if (minidispatch-obj? obj) (do-typeof obj) (k obj))))
(begin
(define-syntax
define-miniobj-typeof
(syntax-rules
()
((_ name ref0 ref1 ... refnext term)
(define-miniobj-typeof
name
ref0
ref1
...
(lambda (obj) (refnext obj term))))
((_ name ref0 term) (define (name obj) (ref0 obj term)))))
(define-syntax
define-miniobj-ref
(syntax-rules
()
((_ name ref0 ref1 ... refnext term)
(define-miniobj-ref
name
ref0
ref1
...
(lambda (obj slot) (refnext obj slot term))))
((_ name ref0 term) (define (name obj slot) (ref0 obj slot term)))))
(define-syntax
define-miniobj-set!
(syntax-rules
()
((_ name set0 set1 ... setnext term)
(define-miniobj-set!
name
set0
set1
...
(lambda (obj slot value) (setnext obj slot value term))))
((_ name set0 term)
(define (name obj slot value) (set0 obj slot value term))))))
(begin
(define %%%export-miniobj-ref~48 #f)
(define %%%export-miniobj-set!~49 #f)
(define %%%export-miniobj-typeof~50 #f)
(let ((miniobj-rnrs-set!-error %%%export-miniobj-rnrs-set!-error~29)
(miniobj-rnrs-ref-error %%%export-miniobj-rnrs-ref-error~28))
(define-miniobj-typeof
miniobj-typeof
miniobj-minidispatch-typeof
miniobj-minitype-typeof
(lambda (_) #f))
(define-miniobj-ref
miniobj-ref
miniobj-minidispatch-ref
miniobj-minitype-ref
miniobj-rnrs-ref-error)
(define-miniobj-set!
miniobj-set!
miniobj-minidispatch-set!
miniobj-minitype-set!
miniobj-rnrs-set!-error)
(set! %%%export-miniobj-ref~48 miniobj-ref)
(set! %%%export-miniobj-set!~49 miniobj-set!)
(set! %%%export-miniobj-typeof~50 miniobj-typeof)))
(begin
(define-syntax
define-invalid-form
(syntax-rules
()
((_ sym)
(define-syntax
sym
(syntax-rules
()
((_) (syntax-error "Invalid form (for aux keyword)")))))))
(define-syntax
define-invalid-forms
(syntax-rules
()
((_ sym) (define-invalid-form sym))
((_ sym0 sym1 ...)
(begin (define-invalid-form sym0) (define-invalid-forms sym1 ...))))))
(begin
(define-syntax
define-syntax-rules/keywords
(syntax-rules
()
((_ nam (symlit ...) (keylit ...) clauses ...)
(define-syntax nam (syntax-rules (symlit ... keylit ...) clauses ...)))))
(define-syntax
define-keywords
(syntax-rules () ((_ key ...) (define-invalid-forms key ...)))))
(begin
(define miniobj-typeof %%%export-miniobj-typeof~50)
(define miniobj-set! %%%export-miniobj-set!~49)
(define miniobj-ref %%%export-miniobj-ref~48)
(define-syntax
ref
(syntax-rules () ((_ target slot) (miniobj-ref target slot))))
(define-syntax
refset!
(syntax-rules () ((_ target slot value) (miniobj-set! target slot value))))
(define-syntax-rules/keywords
~
()
(:=)
((_ target slot := obj) (refset! target slot obj))
((_ target slot) (ref target slot))
((_ target slot next-slot ...) (~ (ref target slot) next-slot ...)))
(define-syntax
define-composite
(syntax-rules () ((_ typename slots) (define-minitype typename slots))))
(define-syntax
~new
(syntax-rules () ((_ typename) (make-minitype-obj typename))))
(define-syntax
let-with
(syntax-rules
()
((_ OBJ (specs0) body ...) (let-with-binder OBJ specs0 body ...))
((_ OBJ (specs0 specs1 ...) body ...)
(let ((myobj OBJ))
(let-with-binder
myobj
specs0
(let-with myobj (specs1 ...) body ...))))))
(define-syntax
let-with*
(syntax-rules
()
((_ (specs0 specs1 ...) body ...)
(let-with specs0 (let-with* (specs1 ...) body ...)))
((_ (specs0) body ...) (let-with specs0 body ...))))
(define-syntax
let-with-binder
(syntax-rules
()
((_ OBJ (bindname name) body ...)
(let ((bindname (~ OBJ 'name))) body ...))
((_ OBJ name body ...) (let ((name (~ OBJ 'name))) body ...))))
(define-syntax typeof (syntax-rules () ((_ obj) (miniobj-typeof obj))))
(define-syntax
is-a?
(syntax-rules
()
((_ obj type) (and type (eq? type (miniobj-typeof obj))))))
(define-syntax
make-apply-rule1!
(syntax-rules
()
((_ NAME (slot body)) (let ((result body)) (~ NAME 'slot := result)))))
(define-syntax
make
(syntax-rules
()
((_ TYPE rule0 ...)
(let ((new-object ((~new TYPE))))
(make-apply-rule1! new-object rule0)
...
new-object))))
(define-syntax
touch!-bind-spec1
(syntax-rules
()
((_ OBJ (slot) body ...) (begin body ...))
((_ OBJ (#f slot) body ...) (begin body ...))
((_ OBJ (bind slot) body ...) (let-with OBJ ((bind slot)) body ...))
((_ OBJ slot body ...) (touch!-bind-spec1 OBJ (slot slot) body ...))))
(define-syntax
touch!-bind-spec
(syntax-rules
()
((_ OBJ (spec0) body ...) (touch!-bind-spec1 OBJ spec0 body ...))
((_ OBJ (spec0 spec1 ...) body ...)
(touch!-bind-spec1
OBJ
spec0
(touch!-bind-spec OBJ (spec1 ...) body ...)))))
(define-syntax
touch!-apply-spec1!
(syntax-rules
()
((_ OBJ (slot) body ...) (~ OBJ 'slot := body ...))
((_ OBJ (#f slot) body ...) (~ OBJ 'slot := body ...))
((_ OBJ (bind slot) body ...) (~ OBJ 'slot := body ...))
((_ OBJ slot body ...) (~ OBJ 'slot := body ...))))
(define-syntax
touch!
(syntax-rules
()
((_ OBJ (bind-spec0 body-spec0) ...)
(let ((myobj OBJ))
(touch!-bind-spec
myobj
(bind-spec0 ...)
(touch!-apply-spec1! myobj bind-spec0 body-spec0)
...
myobj)))))
(define (type-check sym id-name type-name id type)
(if (is-a? id type)
'ok
(begin (error "yuni: type violation" id-name type-name))))
(define-syntax
annotate-check
(syntax-rules
()
((_ sym (id type)) (type-check sym 'id 'type id type))
((_ sym id) 'ok)))
(define-syntax raw-name (syntax-rules () ((_ id) id) ((_ (id type)) id)))
(define-syntax
lambda*0-itr
(syntax-rules
()
((_ sym (cur ...) (spec ...) ((id bogus) rest0 ...) last body ...)
(lambda*0-itr
sym
(cur ... id)
((id bogus) spec ...)
(rest0 ...)
last
body
...))
((_ sym (cur ...) (spec ...) ((id) rest0 ...) last body ...)
(let ((lambda*0-proxy id))
(lambda*0-itr
sym
(cur ...)
(spec ...)
((id lambda*0-proxy) rest0 ...)
last
body
...)))
((_ sym (cur ...) (spec ...) (id rest0 ...) last body ...)
(lambda*0-itr sym (cur ... id) (spec ...) (rest0 ...) last body ...))
((_ sym (cur ...) (spec ...) () () body ...)
(lambda (cur ...) (annotate-check sym spec) ... (let () body ...)))
((_ sym (cur ...) (spec ...) () (last-id last-type) body ...)
(lambda (cur ... . last-id)
(for-each (lambda (e) (annotate-check e last-type)) last-id)
(annotate-check sym spec)
...
(let () body ...)))
((_ sym (cur ...) (spec ...) () last body ...)
(lambda (cur ... . last)
(annotate-check sym spec)
...
(let () body ...)))))
(define-syntax
lambda*0
(syntax-rules
()
((_ sym (spec0 ...) last body ...)
(lambda*0-itr sym () () (spec0 ...) last body ...))))
(define (lookup-property form sym def)
(define (fail) (values def form))
(define (itr ret top next rest)
(if (eq? sym top)
(values next (append (reverse ret) rest))
(if (pair? rest)
(itr (cons top ret) next (car rest) (cdr rest))
(fail))))
(if (and (pair? form) (pair? (cdr form)))
(itr '() (car form) (cadr form) (cddr form))
(fail)))
(define-syntax
let-property
(syntax-rules
()
((_ form out #() proc) (let ((out form)) proc))
((_ form out #(sym) proc) (let-property form out #(sym #f) proc))
((_ form out #(sym def) proc)
(let-values (((sym out) (lookup-property form 'sym def))) proc))))
(define-syntax
let-properties
(syntax-rules
()
((_ form () proc) (apply proc form))
((_ form (props0 props1 ...) proc)
(let-property form out props0 (let-properties out (props1 ...) proc)))))
(define-syntax
flatten-properties-itr
(syntax-rules
()
((_ form (out ...) (#((obj ...) rest ...) next ...) proc)
(flatten-properties-itr
form
(out ... #(obj ...))
(#(rest ...) next ...)
proc))
((_ form (out ...) (next0 next1 ...) proc)
(flatten-properties-itr form (out ... next0) (next1 ...) proc))
((_ form (out ...) () proc) (let-properties form (out ...) proc))))
(define-syntax
flatten-properties
(syntax-rules
()
((_ form (obj ...) proc)
(flatten-properties-itr form () (obj ...) proc))))
(define-syntax
lambda*1-itr
(syntax-rules
()
((_ sym (prop ...) (out ...) (#(propx ...) spec0 ...) last body ...)
(lambda*1-itr
sym
(#(propx ...) prop ...)
(out ...)
(spec0 ...)
last
body
...))
((_ sym (prop ...) (out ...) (spec0 spec1 ...) last body ...)
(lambda*1-itr sym (prop ...) (out ... spec0) (spec1 ...) last body ...))
((_ sym () (out ...) () last body ...)
(lambda*0 sym (out ...) last body ...))
((_ sym (prop0 ...) (out ...) () last body ...)
(lambda property-input
(flatten-properties
property-input
(prop0 ...)
(lambda*0 sym (out ...) last body ...))))))
(define-syntax
lambda*1
(syntax-rules
()
((_ sym (spec0 ...) body ...)
(lambda*1-itr sym () () (spec0 ...) () body ...))))
(define-syntax
lambda*
(syntax-rules () ((_ spec body ...) (lambda*1 'lambda spec body ...))))
(define-syntax
define*
(syntax-rules
()
((_ (name . spec) body ...) (define name (lambda*1 'name spec body ...)))
((_ name spec) (define-composite name spec))))
(define-keywords :=))
(begin
(define-syntax
match-syntax-error
(syntax-rules
()
((_) (match-syntax-error "invalid match-syntax-error usage"))))
(define-syntax
match
(syntax-rules
()
((match) (match-syntax-error "missing match expression"))
((match atom) (match-syntax-error "missing match clause"))
((match (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next v (app ...) (set! (app ...)) (pat . body) ...)))
((match #(vec ...) (pat . body) ...)
(let ((v #(vec ...))) (match-next v v (set! v) (pat . body) ...)))
((match atom (pat . body) ...)
(match-next atom atom (set! atom) (pat . body) ...))))
(define-syntax
match-next
(syntax-rules
(=>)
((match-next v g s) (error "no matching pattern"))
((match-next v g s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g s . rest))))
(match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
((match-next v g s (pat . body) . rest)
(match-next v g s (pat (=> failure) . body) . rest))))
(define-syntax
match-one
(syntax-rules
()
((match-one v (p q . r) g s sk fk i)
(match-check-ellipse
q
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
(match-two v (p q . r) g s sk fk i)))
((match-one . x) (match-two . x))))
(define-syntax
match-two
(syntax-rules
(___ quote quasiquote ? $ = and or not set! get!)
((match-two v () g s (sk ...) fk i) (if (null? v) (sk ... i) fk))
((match-two v 'p g s (sk ...) fk i) (if (equal? v 'p) (sk ... i) fk))
((match-two v `p g s sk fk i) (match-quasiquote v p g s sk fk i))
((match-two v (and) g s (sk ...) fk i) (sk ... i))
((match-two v (and p q ...) g s sk fk i)
(match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
((match-two v (or) g s sk fk i) fk)
((match-two v (or p) g s sk fk i) (match-one v p g s sk fk i))
((match-two v (or p ...) g s sk fk i)
(match-extract-vars
(or p ...)
(match-gen-or v (p ...) g s sk fk i)
i
()))
((match-two v (not p) g s (sk ...) fk i)
(match-one v p g s (match-drop-ids fk) (sk ... i) i))
((match-two v (get! getter) g s (sk ...) fk i)
(let ((getter (lambda () g))) (sk ... i)))
((match-two v (set! setter) g (s ...) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
((match-two v (? pred p ...) g s sk fk i)
(if (pred v) (match-one v (and p ...) g s sk fk i) fk))
((match-two v (= proc p) g s sk fk i)
(let ((w (proc v))) (match-one w p g s sk fk i)))
((match-two v (p ___ . r) g s sk fk i)
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
((match-two v (p) g s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ((w (car v))) (match-one w p (car v) (set-car! v) sk fk i))
fk))
((match-two v (p . q) g s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-one
w
p
(car v)
(set-car! v)
(match-one x q (cdr v) (set-cdr! v) sk fk)
fk
i))
fk))
((match-two v #(p ...) g s sk fk i) (match-vector v 0 () (p ...) sk fk i))
((match-two v x g s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules
(id ...)
((new-sym? x sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym?
random-sym-to-match
(let ((x v)) (sk ... (id ... x)))
(if (equal? v x) (sk ... (id ...)) fk))))))
(define-syntax
match-quasiquote
(syntax-rules
(unquote unquote-splicing quasiquote)
((_ v ,p g s sk fk i) (match-one v p g s sk fk i))
((_ v (,@p . rest) g s sk fk i)
(if (pair? v)
(match-one v (p . tmp) (match-quasiquote tmp rest g s sk fk) fk i)
fk))
((_ v `p g s sk fk i . depth)
(match-quasiquote v p g s sk fk i #f . depth))
((_ v ,p g s sk fk i x . depth)
(match-quasiquote v p g s sk fk i . depth))
((_ v ,@p g s sk fk i x . depth)
(match-quasiquote v p g s sk fk i . depth))
((_ v (p . q) g s sk fk i . depth)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-quasiquote
w
p
g
s
(match-quasiquote-step x q g s sk fk depth)
fk
i
.
depth))
fk))
((_ v #(elt ...) g s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote ls (elt ...) g s sk fk i . depth))
fk))
((_ v x g s sk fk i . depth) (match-one v 'x g s sk fk i))))
(define-syntax
match-quasiquote-step
(syntax-rules
()
((match-quasiquote-step x q g s sk fk depth i)
(match-quasiquote x q g s sk fk i . depth))))
(define-syntax match-drop-ids (syntax-rules () ((_ expr ids ...) expr)))
(define-syntax
match-gen-or
(syntax-rules
()
((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
(match-gen-or-step
v
p
g
s
(match-drop-ids (sk2 id ...))
fk
(i ...))))))
(define-syntax
match-gen-or-step
(syntax-rules
()
((_ v () g s sk fk i) fk)
((_ v (p) g s sk fk i) (match-one v p g s sk fk i))
((_ v (p . q) g s sk fk i)
(match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))))
(define-syntax
match-gen-ellipses
(syntax-rules
()
((_ v p () g s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier
p
(let ((p v)) (if (list? p) (sk ... i) fk))
(let loop ((ls v) (id-ls '()) ...)
(cond ((null? ls) (let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ((w (car ls)))
(match-one
w
p
(car ls)
(set-car! ls)
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk
i)))
(else fk)))))
((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
(match-verify-no-ellipses
(r ...)
(let* ((tail-len (length '(r ...))) (ls v) (len (length ls)))
(if (< len tail-len)
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond ((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls (r ...) #f #f (sk ... i) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one
w
p
(car ls)
(set-car! ls)
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else fk)))))))))
(define-syntax
match-verify-no-ellipses
(syntax-rules
()
((_ (x . y) sk)
(match-check-ellipse
x
(match-syntax-error
"multiple ellipse patterns not allowed at same level")
(match-verify-no-ellipses y sk)))
((_ x sk) sk)))
(define-syntax
match-vector
(syntax-rules
(___)
((_ v n pats (p q) sk fk i)
(match-check-ellipse
q
(match-vector-ellipses v n pats p sk fk i)
(match-vector-two v n pats (p q) sk fk i)))
((_ v n pats (p ___) sk fk i) (match-vector-ellipses v n pats p sk fk i))
((_ . x) (match-vector-two . x))))
(define-syntax
match-vector-two
(syntax-rules
()
((_ v n ((pat index) ...) () sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (= len n) (match-vector-step v ((pat index) ...) sk fk i) fk))
fk))
((_ v n (pats ...) (p . q) sk fk i)
(match-vector v (+ n 1) (pats ... (p n)) q sk fk i))))
(define-syntax
match-vector-step
(syntax-rules
()
((_ v () (sk ...) fk i) (sk ... i))
((_ v ((pat index) . rest) sk fk i)
(let ((w (vector-ref v index)))
(match-one
w
pat
(vector-ref v index)
(vector-set! v index)
(match-vector-step v rest sk fk)
fk
i)))))
(define-syntax
match-vector-ellipses
(syntax-rules
()
((_ v n ((pat index) ...) p sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (>= len n)
(match-vector-step
v
((pat index) ...)
(match-vector-tail v p n len sk fk)
fk
i)
fk))
fk))))
(define-syntax
match-vector-tail
(syntax-rules
()
((_ v p n len sk fk i)
(match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
(define-syntax
match-vector-tail-two
(syntax-rules
()
((_ v p n len (sk ...) fk i ((id id-ls) ...))
(let loop ((j n) (id-ls '()) ...)
(if (>= j len)
(let ((id (reverse id-ls)) ...) (sk ... i))
(let ((w (vector-ref v j)))
(match-one
w
p
(vector-ref v j)
(vetor-set! v j)
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk
i)))))))
(define-syntax
match-extract-vars
(syntax-rules
(___ ? $ = quote quasiquote and or not get! set!)
((match-extract-vars (? pred . p) k i v) (match-extract-vars p k i v))
((match-extract-vars ($ rec . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (= proc p) k i v) (match-extract-vars p k i v))
((match-extract-vars 'x (k ...) i v) (k ... v))
((match-extract-vars `x k i v)
(match-extract-quasiquote-vars x k i v (#t)))
((match-extract-vars (and . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (or . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (not . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars (p . r) k i v)
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars (p . q) k i v)
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
((match-extract-vars #(p ...) k i v) (match-extract-vars (p ...) k i v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars p (k ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules
(i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
(new-sym? random-sym-to-match (k ... ((p p-ls) . v)) (k ... v))))))
(define-syntax
match-extract-vars-step
(syntax-rules
()
((_ p k i v ((v2 v2-ls) ...))
(match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))))
(define-syntax
match-extract-quasiquote-vars
(syntax-rules
(quasiquote unquote unquote-splicing)
((match-extract-quasiquote-vars `x k i v d)
(match-extract-quasiquote-vars x k i v (#t . d)))
((match-extract-quasiquote-vars ,@x k i v d)
(match-extract-quasiquote-vars ,x k i v d))
((match-extract-quasiquote-vars ,x k i v (#t))
(match-extract-vars x k i v))
((match-extract-quasiquote-vars ,x k i v (#t . d))
(match-extract-quasiquote-vars x k i v d))
((match-extract-quasiquote-vars (x . y) k i v (#t . d))
(match-extract-quasiquote-vars
x
(match-extract-quasiquote-vars-step y k i v d)
i
()))
((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars (x ...) k i v d))
((match-extract-quasiquote-vars x (k ...) i v (#t . d)) (k ... v))))
(define-syntax
match-extract-quasiquote-vars-step
(syntax-rules
()
((_ x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars
x
k
(v2 ... . i)
((v2 v2-ls) ... . v)
d))))
(define-syntax
match-lambda
(syntax-rules () ((_ clause ...) (lambda (expr) (match expr clause ...)))))
(define-syntax
match-lambda*
(syntax-rules () ((_ clause ...) (lambda expr (match expr clause ...)))))
(define-syntax
match-let
(syntax-rules
()
((_ (vars ...) . body) (match-let/helper let () () (vars ...) . body))
((_ loop . rest) (match-named-let loop () . rest))))
(define-syntax
match-letrec
(syntax-rules
()
((_ vars . body) (match-let/helper letrec () () vars . body))))
(define-syntax
match-let/helper
(syntax-rules
()
((_ let ((var expr) ...) () () . body) (let ((var expr) ...) . body))
((_ let ((var expr) ...) ((pat tmp) ...) () . body)
(let ((var expr) ...) (match-let* ((pat tmp) ...) . body)))
((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
(match-let/helper
let
(v ... (tmp expr))
(p ... ((a . b) tmp))
rest
.
body))
((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
(match-let/helper
let
(v ... (tmp expr))
(p ... (#(a ...) tmp))
rest
.
body))
((_ let (v ...) (p ...) ((a expr) . rest) . body)
(match-let/helper let (v ... (a expr)) (p ...) rest . body))))
(define-syntax
match-named-let
(syntax-rules
()
((_ loop ((pat expr var) ...) () . body)
(let loop ((var expr) ...) (match-let ((pat var) ...) . body)))
((_ loop (v ...) ((pat expr) . rest) . body)
(match-named-let loop (v ... (pat expr tmp)) rest . body))))
(define-syntax
match-let*
(syntax-rules
()
((_ () . body) (begin . body))
((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body))))))
(define-syntax
match-check-ellipse
(syntax-rules
()
((match-check-ellipse (a . b) success-k failure-k) failure-k)
((match-check-ellipse #(a ...) success-k failure-k) failure-k)
((match-check-ellipse id success-k failure-k)
(let-syntax
((ellipse?
(syntax-rules
()
((ellipse? (foo id) sk fk) sk)
((ellipse? other sk fk) fk))))
(ellipse? (a b c) success-k failure-k)))))
(define-syntax
match-check-identifier
(syntax-rules
()
((_ (x . y) success-k failure-k) failure-k)
((_ #(x ...) success-k failure-k) failure-k)
((_ x success-k failure-k)
(let-syntax
((sym? (syntax-rules () ((sym? x sk fk) sk) ((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k))))))
(begin
(define-syntax
%let-terms
(syntax-rules
()
((_ (var . varrest) (nam . namrest) body)
(let ((nam var)) (%let-terms varrest namrest body)))
((_ () () body) body)
((_ var nam body) (let ((nam var)) body))))
(define-syntax
%gen-dispatch+case-lambda
(syntax-rules
()
((_ (first . rest) (((withsymtop . withsymrest) body) ...) ())
(case first
((withsymtop) (%let-terms rest withsymrest body))
...
(else (error "unknown command" first (list 'withsymtop ...)))))
((_ f () ((f2 body))) (%let-terms f f2 body))
((_ (first . rest) (((withsymtop . withsymrest) body) ...) ((f elsebody)))
(case first
((withsymtop) (%let-terms rest withsymrest body))
...
(else (%let-terms (first . rest) f elsebody))))))
(define-syntax
%sort-dispatch-clauses
(syntax-rules
(quote)
((_ with without f ()) (%gen-dispatch+case-lambda f with without))
((_ with without f ((('sym . rest) body) . next))
(%sort-dispatch-clauses (((sym . rest) body) . with) without f next))
((_ with without f (cur . next))
(%sort-dispatch-clauses with (cur . without) f next))))
(define-syntax
%output-case-lambda
(syntax-rules
()
((_ cur (f ()) next ...) (%output-case-lambda cur next ...))
((_ cur valid-entry next ...)
(%output-case-lambda (valid-entry . cur) next ...))
((_ ((f clauses) ...))
(case-lambda (f (%sort-dispatch-clauses () () f clauses)) ...))))
(define-syntax
%gen-case-lambda
(syntax-rules
()
((_ $0 $0+ $1 $1+ $2 $2+ $3 $3+ $4 $4+ $5 $5+ $6 $6+ $7 $7+ $8 $8+ $9 $9+)
(%output-case-lambda
()
(() $0)
((x1) $1)
((x1 x2) $2)
((x1 x2 x3) $3)
((x1 x2 x3 x4) $4)
((x1 x2 x3 x4 x5) $5)
((x1 x2 x3 x4 x5 x6) $6)
((x1 x2 x3 x4 x5 x6 x7) $7)
((x1 x2 x3 x4 x5 x6 x7 x8) $8)
((x1 x2 x3 x4 x5 x6 x7 x8 x9) $9)
((x1 x2 x3 x4 x5 x6 x7 x8 x9 . x) $9+)
((x1 x2 x3 x4 x5 x6 x7 x8 . x) $8+)
((x1 x2 x3 x4 x5 x6 x7 . x) $7+)
((x1 x2 x3 x4 x5 x6 . x) $6+)
((x1 x2 x3 x4 x5 . x) $5+)
((x1 x2 x3 x4 . x) $4+)
((x1 x2 x3 . x) $3+)
((x1 x2 . x) $2+)
((x1 . x) $1+)
(wam $0+)))))
(define-syntax
%sort-clauses
(syntax-rules
()
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ...) body ...) . bogus))
(syntax-error "Too many arguments"))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
())
(%gen-case-lambda
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
((() body ...) . next))
(%sort-clauses
((() (begin body ...)) . $0)
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1) body ...) . next))
(%sort-clauses
$0
$0+
(((x1) (begin body ...)) . $1)
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
(((x1 x2) (begin body ...)) . $2)
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
(((x1 x2 x3) (begin body ...)) . $3)
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
(((x1 x2 x3 x4) (begin body ...)) . $4)
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
(((x1 x2 x3 x4 x5) (begin body ...)) . $5)
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
(((x1 x2 x3 x4 x5 x6) (begin body ...)) . $6)
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
(((x1 x2 x3 x4 x5 x6 x7) (begin body ...)) . $7)
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 x8) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
(((x1 x2 x3 x4 x5 x6 x7 x8) (begin body ...)) . $8)
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 x8 x9) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
(((x1 x2 x3 x4 x5 x6 x7 x8 x9) (begin body ...)) . $9)
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 x8 x9 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
(((x1 x2 x3 x4 x5 x6 x7 x8 x9 . x) (begin body ...)) . $9+)
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 x8 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
(((x1 x2 x3 x4 x5 x6 x7 x8 . x) (begin body ...)) . $8+)
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 x7 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
(((x1 x2 x3 x4 x5 x6 x7 . x) (begin body ...)) . $7+)
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 x6 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
(((x1 x2 x3 x4 x5 x6 . x) (begin body ...)) . $6+)
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 x5 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
(((x1 x2 x3 x4 x5 . x) (begin body ...)) . $5+)
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 x4 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
(((x1 x2 x3 x4 . x) (begin body ...)) . $4+)
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 x3 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
$2+
$3
(((x1 x2 x3 . x) (begin body ...)) . $3+)
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 x2 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
$1+
$2
(((x1 x2 . x) (begin body ...)) . $2+)
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
(((x1 . x) body ...) . next))
(%sort-clauses
$0
$0+
$1
(((x1 . x) (begin body ...)) . $1+)
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))
((_ $0
$0+
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
((x body ...) . next))
(%sort-clauses
$0
((x (begin body ...)) . $0+)
$1
$1+
$2
$2+
$3
$3+
$4
$4+
$5
$5+
$6
$6+
$7
$7+
$8
$8+
$9
$9+
next))))
(define-syntax
dispatch-lambda
(syntax-rules
()
((_ clauses ...)
(%sort-clauses
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
()
(clauses ...))))))
(begin
(define %%%export-ssplit-byte-delimiter?~51 #f)
(define %%%export-ssplit-byte-whitespace?~52 #f)
(define %%%export-ssplit-byte-class~53 #f)
(let ()
(define-syntax
%bcdef
(syntax-rules
()
((_ (char sym) ...)
(let ((sym char) ...)
(lambda (b) (cond ((= sym b) 'sym) ... (else #f)))))))
(define (ssplit-byte-whitespace? byte)
(case (ssplit-byte-class byte) ((SPACE TAB CR LF) #t) (else #f)))
(define (ssplit-byte-delimiter? byte)
(or (ssplit-byte-whitespace? byte)
(case (ssplit-byte-class byte)
((PAREN_L PAREN_R SQ_L SQ_R SEMICOLON SHARP DQUOTE) #t)
(else #f))))
(define ssplit-byte-class
(%bcdef (32 SPACE)
(9 TAB)
(13 CR)
(10 LF)
(40 PAREN_L)
(41 PAREN_R)
(91 SQ_L)
(93 SQ_R)
(59 SEMICOLON)
(35 SHARP)
(34 DQUOTE)
(92 BACKSLASH)
(39 QUOTE)
(64 AT)
(44 COMMA)
(124 PIPE)
(96 BQUOTE)
(116 SMALL-T)
(102 SMALL-F)
(84 LARGE-T)
(70 LARGE-F)))
(set! %%%export-ssplit-byte-delimiter?~51 ssplit-byte-delimiter?)
(set! %%%export-ssplit-byte-whitespace?~52 ssplit-byte-whitespace?)
(set! %%%export-ssplit-byte-class~53 ssplit-byte-class)))
(begin
(define %%%export-ssplit-parse-byte0~54 #f)
(define %%%export-ssplit-parse-byte1~55 #f)
(define %%%export-ssplit-parse-byte2~56 #f)
(define %%%export-ssplit-instring-parse-byte0~57 #f)
(define %%%export-ssplit-instring-parse-byte1~58 #f)
(define %%%export-ssplit-incomment-parse-byte0~59 #f)
(define %%%export-ssplit-incomment-parse-byte1~60 #f)
(define %%%export-ssplit-inblockcomment-parse-byte0~61 #f)
(define %%%export-ssplit-inblockcomment-parse-byte1~62 #f)
(let ((ssplit-byte-class %%%export-ssplit-byte-class~53)
(ssplit-byte-whitespace? %%%export-ssplit-byte-whitespace?~52)
(ssplit-byte-delimiter? %%%export-ssplit-byte-delimiter?~51))
(define-syntax
%expand-clause
(syntax-rules
()
((_ single) (values 'single #f))
((_ has-next #t) (values 'has-next #t))))
(define-syntax
%dispatch0
(syntax-rules
(=>)
((_ byte (sym => clause ...) ...)
(let ((cls (ssplit-byte-class byte)))
(case cls
((sym) (%expand-clause clause ...))
...
(else (values 'OTHERS #f)))))))
(define-syntax
%dispatch
(syntax-rules
(=>)
((_ prev-sym byte (from to => clause ...) ...)
(let ((cls (ssplit-byte-class byte)))
(cond ((and (eq? prev-sym 'from) (eq? cls 'to))
(%expand-clause clause ...))
...
(else (values 'OTHERS #f)))))))
(define (ssplit-parse-byte0 byte)
(%dispatch0
byte
(PAREN_L => LIST_BEGIN_PAREN)
(PAREN_R => LIST_END_PAREN)
(SQ_L => LIST_BEGIN_SQ)
(SQ_R => LIST_END_SQ)
(QUOTE => NEXT_QUOTE)
(BQUOTE => NEXT_QUASIQUOTE)
(COMMA => NEXT_UNQUOTE #t)
(SPACE => SPACE)
(CR => CR #t)
(LF => LF)
(SHARP => SHARP #t)
(SEMICOLON => SEMICOLON)
(DQUOTE => DQUOTE)))
(define (ssplit-parse-byte1 byte prev-sym)
(%dispatch
prev-sym
byte
(SHARP QUOTE => NEXT_SYNTAX_QUOTE)
(SHARP BQUOTE => NEXT_SYNTAX_QUASIQUOTE)
(SHARP COMMA => NEXT_SYNTAX_UNQUOTE #t)
(NEXT_UNQUOTE AT => NEXT_UNQUOTE_SPLICING)
(SHARP BACKSLASH => NEXT_CHAR_LITERAL)
(SHARP PIPE => BLOCK_COMMENT_BEGIN)
(SHARP SEMICOLON => NEXT_DATUM_COMMENT)
(CR LF => CRLF)
(SHARP SMALL-T => TRUE)
(SHARP SMALL-F => FALSE)
(SHARP LARGE-T => TRUE)
(SHARP LARGE-F => FALSE)))
(define (ssplit-parse-byte2 byte prev-sym)
(%dispatch
prev-sym
byte
(NEXT_SYNTAX_UNQUOTE AT => NEXT_SYNTAX_UNQUOTE_SPLICING)))
(define (ssplit-instring-parse-byte0 byte)
(%dispatch0
byte
(BACKSLASH => BACKSLASH #t)
(DQUOTE => DQUOTE)
(CR => CR #t)
(LF => LF)))
(define (ssplit-instring-parse-byte1 byte prev-sym)
(%dispatch
prev-sym
byte
(CR LF => CRLF)
(BACKSLASH DQUOTE => ESCAPE_DQUOTE)))
(define (ssplit-incomment-parse-byte0 byte)
(%dispatch0 byte (CR => CR #t) (LF => LF) (SEMICOLON => SEMICOLON)))
(define (ssplit-incomment-parse-byte1 byte prev-sym)
(%dispatch prev-sym byte (CR LF => CRLF)))
(define (ssplit-inblockcomment-parse-byte0 byte)
(%dispatch0
byte
(PIPE => PIPE #t)
(SHARP => SHARP #t)
(CR => CR #t)
(LF => LF)))
(define (ssplit-inblockcomment-parse-byte1 byte prev-sym)
(%dispatch
prev-sym
byte
(PIPE SHARP => BLOCK_COMMENT_END)
(SHARP PIPE => BLOCK_COMMENT_BEGIN)
(CR LF => CRLF)))
(set! %%%export-ssplit-parse-byte0~54 ssplit-parse-byte0)
(set! %%%export-ssplit-parse-byte1~55 ssplit-parse-byte1)
(set! %%%export-ssplit-parse-byte2~56 ssplit-parse-byte2)
(set! %%%export-ssplit-instring-parse-byte0~57
ssplit-instring-parse-byte0)
(set! %%%export-ssplit-instring-parse-byte1~58
ssplit-instring-parse-byte1)
(set! %%%export-ssplit-incomment-parse-byte0~59
ssplit-incomment-parse-byte0)
(set! %%%export-ssplit-incomment-parse-byte1~60
ssplit-incomment-parse-byte1)
(set! %%%export-ssplit-inblockcomment-parse-byte0~61
ssplit-inblockcomment-parse-byte0)
(set! %%%export-ssplit-inblockcomment-parse-byte1~62
ssplit-inblockcomment-parse-byte1)))
(begin
(define %%%export-make-miniread~63 #f)
(define %%%export-make-tkn~64 #f)
(define %%%export-tkn-start-stream~65 #f)
(define %%%export-tkn-start-index~66 #f)
(define %%%export-tkn-start-lineno~67 #f)
(define %%%export-tkn-start-column~68 #f)
(define %%%export-tkn-end-stream~69 #f)
(define %%%export-tkn-end-index~70 #f)
(define %%%export-tkn-end-lineno~71 #f)
(define %%%export-tkn-end-column~72 #f)
(define %%%export-tkn-type~73 #f)
(define %%%export-miniread-main~74 #f)
(let ((ssplit-inblockcomment-parse-byte1
%%%export-ssplit-inblockcomment-parse-byte1~62)
(ssplit-inblockcomment-parse-byte0
%%%export-ssplit-inblockcomment-parse-byte0~61)
(ssplit-incomment-parse-byte1
%%%export-ssplit-incomment-parse-byte1~60)
(ssplit-incomment-parse-byte0
%%%export-ssplit-incomment-parse-byte0~59)
(ssplit-instring-parse-byte1 %%%export-ssplit-instring-parse-byte1~58)
(ssplit-instring-parse-byte0 %%%export-ssplit-instring-parse-byte0~57)
(ssplit-parse-byte2 %%%export-ssplit-parse-byte2~56)
(ssplit-parse-byte1 %%%export-ssplit-parse-byte1~55)
(ssplit-parse-byte0 %%%export-ssplit-parse-byte0~54)
(ssplit-byte-class %%%export-ssplit-byte-class~53)
(ssplit-byte-whitespace? %%%export-ssplit-byte-whitespace?~52)
(ssplit-byte-delimiter? %%%export-ssplit-byte-delimiter?~51))
(define* miniread
(state reg
hold
hold-stream
hold-index
lineno
column
blockcomment-depth
start-stream
start-index
start-lineno
start-column
prev-type
prev-stream
prev-index
prev-lineno
prev-column))
(define* tokenvec-entry
(start-stream
start-index
start-lineno
start-column
end-stream
end-index
end-lineno
end-column
type))
(define (make-tkn num)
(list->vector
(map (lambda (e) (make tokenvec-entry))
(vector->list (make-vector num)))))
(define (%tref vec idx sym) (~ (vector-ref vec idx) sym))
(define (tkn-start-stream vec idx) (%tref vec idx 'start-stream))
(define (tkn-start-index vec idx) (%tref vec idx 'start-index))
(define (tkn-start-lineno vec idx) (%tref vec idx 'start-lineno))
(define (tkn-start-column vec idx) (%tref vec idx 'start-column))
(define (tkn-end-stream vec idx) (%tref vec idx 'end-stream))
(define (tkn-end-index vec idx) (%tref vec idx 'end-index))
(define (tkn-end-lineno vec idx) (%tref vec idx 'end-lineno))
(define (tkn-end-column vec idx) (%tref vec idx 'end-column))
(define (tkn-type vec idx) (%tref vec idx 'type))
(define (make-miniread)
(make miniread (blockcomment-depth 0) (hold #f) (state #f)))
(define (miniread-main mr vec vecidx vecend cb)
(define terminate? #f)
(define curidx vecidx)
(define retidx #f)
(define (state) (~ mr 'state))
(define (set-state! st) (~ mr 'state := st))
(define (blockcomment-depth-zero?) (zero? (~ mr 'blockcomment-depth)))
(define (%blockcomment-depth-add! x)
(let ((d (~ mr 'blockcomment-depth)))
(~ mr 'blockcomment-depth := (+ x d))))
(define (blockcomment-depth++) (%blockcomment-depth-add! 1))
(define (blockcomment-depth--) (%blockcomment-depth-add! -1))
(define (callstep next b stream index)
(define (step type has-next?)
(define prev-type (~ mr 'reg))
(~ mr 'reg := type)
(next b (state) prev-type type has-next? stream index))
(define (dostep0 p) (call-with-values (lambda () (p b)) step))
(define (dostep p)
(call-with-values (lambda () (p b (~ mr 'reg))) step))
(case (state)
((CHARLIT) (next b 'CHARLIT #f 'CHARLIT #f stream index))
((#f OBJ0 OBJ0/SHARP) (dostep0 ssplit-parse-byte0))
((OBJ1 OBJ1/SHARP) (dostep ssplit-parse-byte1))
((OBJ2) (dostep ssplit-parse-byte2))
((STRING0) (dostep0 ssplit-instring-parse-byte0))
((STRING1) (dostep ssplit-instring-parse-byte1))
((LINECOMMENT0) (dostep0 ssplit-incomment-parse-byte0))
((LINECOMMENT1) (dostep ssplit-incomment-parse-byte1))
((BLOCKCOMMENT0) (dostep0 ssplit-inblockcomment-parse-byte0))
((BLOCKCOMMENT1) (dostep ssplit-inblockcomment-parse-byte1))
(else (error "unexpected state" (state)))))
(define (char b st prev-type type has-next? stream index)
(define (whitespace?) (ssplit-byte-whitespace? b))
(define (delimiter?) (ssplit-byte-delimiter? b))
(define (paren-l?) (eq? 'PAREN_L (ssplit-byte-class b)))
(define (hold)
(~ mr 'hold := b)
(~ mr 'hold-index := index)
(~ mr 'hold-stream := stream))
(define (set-prev-here type)
(~ mr 'prev-type := type)
(~ mr 'prev-stream := stream)
(~ mr 'prev-index := index)
(~ mr 'prev-lineno := (~ mr 'lineno))
(~ mr 'prev-column := (~ mr 'column)))
(define (begin-here next-state)
(let ((st (state)))
(when (and st (not (eq? st 'CHARLIT)))
(error "Invalid state at begin-here" st)))
(~ mr 'state := next-state)
(~ mr 'start-stream := stream)
(~ mr 'start-index := index)
(~ mr 'start-lineno := (~ mr 'lineno))
(~ mr 'start-column := (~ mr 'column)))
(define (%tkn-set-start! tkn type)
(~ tkn 'type := type)
(~ tkn 'start-stream := (~ mr 'start-stream))
(~ tkn 'start-index := (~ mr 'start-index))
(~ tkn 'start-lineno := (~ mr 'start-lineno))
(~ tkn 'start-column := (~ mr 'start-column)))
(define (%emit-tkn!)
(~ mr 'state := #f)
(set! retidx curidx)
(set! curidx (+ 1 curidx)))
(define (end-here tkn-type)
(let ((tkn (vector-ref vec curidx)))
(%tkn-set-start! tkn tkn-type)
(~ tkn 'end-stream := stream)
(~ tkn 'end-index := index)
(~ tkn 'end-lineno := (~ mr 'lineno))
(~ tkn 'end-column := (~ mr 'column)))
(%emit-tkn!))
(define (end-prev)
(let ((tkn (vector-ref vec curidx)))
(%tkn-set-start! tkn (~ mr 'prev-type))
(~ tkn 'end-stream := (~ mr 'prev-stream))
(~ tkn 'end-index := (~ mr 'prev-index))
(~ tkn 'end-lineno := (~ mr 'prev-lineno))
(~ tkn 'end-column := (~ mr 'prev-column)))
(%emit-tkn!))
(define (tkn-single tkn-type) (begin-here #f) (end-here tkn-type))
(case st
((CHARLIT) (set-prev-here 'OBJ) (set-state! 'OBJ0))
((#f)
(case type
((LIST_BEGIN_PAREN
LIST_END_PAREN
LIST_BEGIN_SQ
LIST_END_SQ
NEXT_QUOTE
NEXT_QUASIQUOTE)
(tkn-single type))
((SEMICOLON) (begin-here 'LINECOMMENT0))
((DQUOTE) (begin-here 'STRING0))
((NEXT_UNQUOTE) (set-prev-here 'NEXT_UNQUOTE) (begin-here 'OBJ1))
((SPACE CR LF) 'do-nothing)
((SHARP) (set-prev-here 'OBJ) (begin-here 'OBJ1/SHARP))
(else
(set-prev-here 'OBJ)
(if has-next? (begin-here 'OBJ1) (begin-here 'OBJ0)))))
((OBJ0 OBJ0/SHARP)
(case type
((LIST_BEGIN_PAREN)
(cond ((eq? st 'OBJ0/SHARP) (end-here 'OBJ))
(else (end-prev) (hold) (set-state! #f))))
(else
(cond ((or (whitespace?) (delimiter?))
(end-prev)
(hold)
(set-state! #f))
(else
(set-prev-here 'OBJ)
(when has-next? (set-state! 'OBJ1)))))))
((OBJ1 OBJ1/SHARP)
(case type
((NEXT_CHAR_LITERAL) (set-prev-here 'OBJ) (set-state! 'CHARLIT))
((NEXT_SYNTAX_QUOTE
NEXT_SYNTAX_QUASIQUOTE
NEXT_UNQUOTE_SPLICING
NEXT_DATUM_COMMENT
TRUE
FALSE)
(end-here type))
((BLOCK_COMMENT_BEGIN)
(blockcomment-depth++)
(set-state! 'BLOCKCOMMENT0))
(else
(case prev-type
((NEXT_UNQUOTE) (end-prev) (hold) (set-state! #f))
(else
(cond ((and (eq? st 'OBJ1/SHARP) (paren-l?)) (end-here 'OBJ))
((delimiter?) (end-prev) (hold) (set-state! #f))
(else
(hold)
(if (eq? st 'OBJ1/SHARP)
(set-state! 'OBJ0/SHARP)
(set-state! 'OBJ0)))))))))
((OBJ2)
(case type
((NEXT_SYNTAX_UNQUOTE_SPLICING) (end-here type))
(else
(case prev-type
((NEXT_SYNTAX_UNQUOTE) (end-prev) (hold) (set-state! #f))
(else (error "???"))))))
((STRING0)
(case type
((BACKSLASH) (set-state! 'STRING1))
((DQUOTE) (end-here 'STRING))
(else 'do-nothing)))
((STRING1) (set-state! 'STRING0))
((LINECOMMENT0)
(case type
((LF) (end-here 'COMMENT))
((CR) (set-prev-here 'COMMENT) (set-state! 'LINECOMMENT1))))
((LINECOMMENT1)
(case type
((CRLF) (end-here 'COMMENT))
(else (end-prev) (hold) (set-state! #f))))
((BLOCKCOMMENT0)
(case type
((PIPE SHARP) (set-state! 'BLOCKCOMMENT1))
(else 'do-nothing)))
((BLOCKCOMMENT1)
(case type
((BLOCK_COMMENT_BEGIN) (blockcomment-depth++))
((BLOCK_COMMENT_END)
(blockcomment-depth--)
(cond ((blockcomment-depth-zero?)
(end-here 'COMMENT)
(set-state! #f))
(else (set-state! 'BLOCKCOMMENT0))))
(else (set-state! 'BLOCKCOMMENT0))))
(else (error "?????"))))
(define (stream-end stream index)
(callstep char 32 #f #f)
(set! terminate? #t))
(define (byte b stream index)
(cond ((eof-object? b) (stream-end stream index))
(else
(unless (integer? b) (error "Invalid value" b))
(callstep char b stream index))))
(define (itr)
(unless (or terminate? (= curidx vecend))
(let ((hold (~ mr 'hold)))
(if hold
(let ((stream (~ mr 'hold-stream))
(index (~ mr 'hold-index)))
(~ mr 'hold := #f)
(byte hold stream index))
(call-with-values cb byte)))
(itr)))
(itr)
retidx)
(set! %%%export-make-miniread~63 make-miniread)
(set! %%%export-make-tkn~64 make-tkn)
(set! %%%export-tkn-start-stream~65 tkn-start-stream)
(set! %%%export-tkn-start-index~66 tkn-start-index)
(set! %%%export-tkn-start-lineno~67 tkn-start-lineno)
(set! %%%export-tkn-start-column~68 tkn-start-column)
(set! %%%export-tkn-end-stream~69 tkn-end-stream)
(set! %%%export-tkn-end-index~70 tkn-end-index)
(set! %%%export-tkn-end-lineno~71 tkn-end-lineno)
(set! %%%export-tkn-end-column~72 tkn-end-column)
(set! %%%export-tkn-type~73 tkn-type)
(set! %%%export-miniread-main~74 miniread-main)))
(begin
(define %%%export-utf8-read~75 #f)
(let ((miniread-main %%%export-miniread-main~74)
(tkn-type %%%export-tkn-type~73)
(tkn-end-column %%%export-tkn-end-column~72)
(tkn-end-lineno %%%export-tkn-end-lineno~71)
(tkn-end-index %%%export-tkn-end-index~70)
(tkn-end-stream %%%export-tkn-end-stream~69)
(tkn-start-column %%%export-tkn-start-column~68)
(tkn-start-lineno %%%export-tkn-start-lineno~67)
(tkn-start-index %%%export-tkn-start-index~66)
(tkn-start-stream %%%export-tkn-start-stream~65)
(make-tkn %%%export-make-tkn~64)
(make-miniread %%%export-make-miniread~63))
(define (%u8-list->bytevector lis)
(define (itr bv cur rest)
(when (pair? rest)
(bytevector-u8-set! bv cur (car rest))
(itr bv (+ cur 1) (cdr rest))))
(let ((bv (make-bytevector (length lis)))) (itr bv 0 lis) bv))
(define (%realize-string-raw bv start end)
(utf8->string bv start (+ 1 end)))
(define (%realize-PLACEHOLDER bv start end)
(let ((s (%realize-string-raw bv start end)))
(read (open-input-string s))))
(define (%realize-string bv start end)
(%realize-PLACEHOLDER bv start end))
(define (%realize-charlit bv start end)
(%realize-PLACEHOLDER bv start end))
(define (%realize-number bv start end)
(string->number (%realize-string-raw bv start end)))
(define (%realize-object bv start end)
(string->symbol (%realize-string-raw bv start end)))
(define (%check-special-token bv start end)
(define s (%realize-string-raw bv start end))
(cond ((or (string=? "#vu8(" s) (string=? "#u8(" s)) 'BYTEVECTOR_BEGIN)
((string=? "#(" s) 'VECTOR_BEGIN)
(else
(let ((head (and (<= 2 (string-length s)) (substring s 0 2))))
(cond ((and head (string=? head "#!")) 'IGNORE)
((and head (string=? head "#\\")) 'CHARLIT)
(else (and (string->number s) 'NUMBER)))))))
(define (%realize bv lst)
(define (elem-type e) (vector-ref e 0))
(define (elem-start e) (vector-ref e 1))
(define (elem-end e) (vector-ref e 2))
(define (itr mode dump cur rest)
(if (pair? rest)
(let ((a (car rest)) (d (cdr rest)))
(let ((type (elem-type a))
(start (elem-start a))
(end (elem-end a)))
(define (go-next mode obj cur dump)
(define (next/pop take? obj)
(let* ((x (car dump))
(prev-cur (car x))
(prev-mode (cdr x))
(next-dump (cdr dump)))
(itr prev-mode
next-dump
(if take? (cons obj prev-cur) prev-cur)
d)))
(define (nextnext x) (itr mode dump (cons x cur) d))
(define (nextnext/pop obj) (next/pop #t obj))
(define (nextdrop/pop) (next/pop #f #f))
(define (nextchar/pop obj)
(define c (string-ref obj 0))
(nextnext/pop c))
(case mode
((NEXT_QUOTE) (nextnext/pop (list 'quote obj)))
((NEXT_QUASIQUOTE) (nextnext/pop (list 'quasiquote obj)))
((NEXT_UNQUOTE) (nextnext/pop (list 'unquote obj)))
((NEXT_UNQUOTE_SPLICING)
(nextnext/pop (list 'unquote-splicing obj)))
((NEXT_SYNTAX_QUOTE) (nextnext/pop (list 'syntax obj)))
((NEXT_SYNTAX_UNQUOTE)
(nextnext/pop (list 'unsyntax obj)))
((NEXT_SYTNAX_UNQUOTE_SPLICING)
(nextnext/pop (list 'unsyntax-splicing obj)))
((NEXT_SYNTAX_QUASIQUOTE)
(nextnext/pop (list 'quasisyntax obj)))
((NEXT_DATUM_COMMENT) (nextdrop/pop))
((NEXT_CHAR_LITERAL) (nextchar/pop obj))
(else (nextnext obj))))
(define (single obj) (go-next mode obj cur dump))
(define (single/pop obj)
(let* ((x (car dump))
(next-dump (cdr dump))
(prev-cur (car x))
(prev-mode (cdr x)))
(go-next prev-mode obj prev-cur next-dump)))
(define (push-to-dump next-mode)
(itr next-mode (cons (cons cur mode) dump) '() d))
(case type
((COMMENT BLOCK_COMMENT) (itr mode dump cur d))
((TRUE) (single #t))
((FALSE) (single #f))
((STRING) (single (%realize-string bv start end)))
((OBJ)
(let ((t (%check-special-token bv start end)))
(case t
((VECTOR_BEGIN) (push-to-dump 'VECTOR))
((BYTEVECTOR_BEGIN) (push-to-dump 'BYTEVECTOR))
((IGNORE) (itr mode dump cur d))
((NUMBER) (single (%realize-number bv start end)))
((CHARLIT) (single (%realize-charlit bv start end)))
(else (single (%realize-object bv start end))))))
((LIST_BEGIN_PAREN LIST_BEGIN_SQ) (push-to-dump 'LIST))
((LIST_END_PAREN LIST_END_SQ)
(let ((obj (case mode
((LIST) (reverse cur))
((VECTOR) (list->vector (reverse cur)))
((BYTEVECTOR)
(%u8-list->bytevector (reverse cur)))
(else (error "unknown mode??" mode)))))
(single/pop obj)))
((NEXT_QUOTE
NEXT_QUASIQUOTE
NEXT_UNQUOTE
NEXT_UNQUOTE_SPLICING
NEXT_SYNTAX_QUOTE
NEXT_SYNTAX_QUASIQUOTE
NEXT_SYNTAX_UNQUOTE_SPLICING
NEXT_DATUM_COMMENT
NEXT_CHAR_LITERAL)
(push-to-dump type))
(else (error "unknown token type??" type)))))
(case mode
((FIRST) (reverse cur))
(else (error "unknown mode?" mode)))))
(itr 'FIRST '() '() lst))
(define (%utf8-in bv)
(define cur 0)
(define len (bytevector-length bv))
(lambda ()
(cond ((= cur len) (values (eof-object) bv cur))
(else
(let ((c cur) (b (bytevector-u8-ref bv cur)))
(set! cur (+ 1 cur))
(values b bv c))))))
(define (utf8-read bv)
(define tkn (make-tkn 1))
(define cb (%utf8-in bv))
(define mr (make-miniread))
(define (capture tkn idx)
(let ((start-index (tkn-start-index tkn idx))
(end-index (tkn-end-index tkn idx))
(type (tkn-type tkn idx)))
(vector type start-index end-index)))
(define (itr cur)
(let ((r (miniread-main mr tkn 0 1 cb)))
(cond ((eq? r #f) (%realize bv (reverse cur)))
((and (number? r) (= r 0)) (itr (cons (capture tkn 0) cur)))
(else (error "something wrong" r)))))
(itr '()))
(set! %%%export-utf8-read~75 utf8-read)))
(begin
(define %%%export-id?~76 #f)
(define %%%export-id-new-variable~77 #f)
(define %%%export-id-new-macro~78 #f)
(define %%%export-id-new-library-variable~79 #f)
(define %%%export-id-new-library-macro~80 #f)
(define %%%export-id-new-primitive~81 #f)
(define %%%export-id-new-aux-syntax~82 #f)
(define %%%export-id-set-global-name!~83 #f)
(define %%%export-id-set-gensym-ident!~84 #f)
(define %%%export-id-set-library!~85 #f)
(define %%%export-id-source-name~86 #f)
(define %%%export-id-global-name~87 #f)
(define %%%export-id-gensym-ident~88 #f)
(define %%%export-id-library~89 #f)
(define %%%export-id-variable?~90 #f)
(define %%%export-id-macro?~91 #f)
(define %%%export-id-aux-syntax?~92 #f)
(define %%%export-id-primitive?~93 #f)
(let ()
(define id-ident (cons 'id '()))
(define (id? obj)
(and (vector? obj)
(>= (vector-length obj) 1)
(eq? id-ident (vector-ref obj 0))))
(define (id-source-name id) (vector-ref id 1))
(define (id-global-name id) (vector-ref id 2))
(define (id-gensym-ident id) (vector-ref id 3))
(define (id-library id) (vector-ref id 4))
(define (%id-type id) (vector-ref id 5))
(define (id-variable? id) (eq? (%id-type id) 'variable))
(define (id-macro? id) (eq? (%id-type id) 'macro))
(define (id-aux-syntax? id) (eq? (%id-type id) 'aux-syntax))
(define (id-primitive? id) (vector-ref id 6))
(define (id-set-global-name! id name) (vector-set! id 2 name))
(define (id-set-gensym-ident! id ident) (vector-set! id 3 ident))
(define (id-set-library! id lib) (vector-set! id 4 lib))
(define (id-new-variable sym) (vector id-ident sym sym 0 #t 'variable #f))
(define (id-new-macro sym) (vector id-ident sym sym 0 #t 'macro #f))
(define (id-new-library-variable sym global lib)
(vector id-ident sym global 0 lib 'variable #f))
(define (id-new-library-macro sym global lib)
(vector id-ident sym global 0 lib 'macro #f))
(define (id-new-primitive sym global lib)
(vector id-ident sym global 0 lib 'variable #t))
(define (id-new-aux-syntax sym lib)
(vector id-ident sym sym 0 lib 'aux-syntax #f))
(set! %%%export-id?~76 id?)
(set! %%%export-id-new-variable~77 id-new-variable)
(set! %%%export-id-new-macro~78 id-new-macro)
(set! %%%export-id-new-library-variable~79 id-new-library-variable)
(set! %%%export-id-new-library-macro~80 id-new-library-macro)
(set! %%%export-id-new-primitive~81 id-new-primitive)
(set! %%%export-id-new-aux-syntax~82 id-new-aux-syntax)
(set! %%%export-id-set-global-name!~83 id-set-global-name!)
(set! %%%export-id-set-gensym-ident!~84 id-set-gensym-ident!)
(set! %%%export-id-set-library!~85 id-set-library!)
(set! %%%export-id-source-name~86 id-source-name)
(set! %%%export-id-global-name~87 id-global-name)
(set! %%%export-id-gensym-ident~88 id-gensym-ident)
(set! %%%export-id-library~89 id-library)
(set! %%%export-id-variable?~90 id-variable?)
(set! %%%export-id-macro?~91 id-macro?)
(set! %%%export-id-aux-syntax?~92 id-aux-syntax?)
(set! %%%export-id-primitive?~93 id-primitive?)))
(begin
(define %%%export-envframe-decl-binding!~94 #f)
(define %%%export-envframe-def-binding!~95 #f)
(define %%%export-envframe-add-binding!~96 #f)
(define %%%export-envframe-only-bindings!~97 #f)
(define %%%export-envframe-except-bindings!~98 #f)
(define %%%export-envframe-prefix-bindings!~99 #f)
(define %%%export-envframe-rename-bindings!~100 #f)
(define %%%export-envframe-lookup~101 #f)
(define %%%export-envframe-lookup-decl~102 #f)
(define %%%export-envframe-lookup-def~103 #f)
(define %%%export-envframe-import!~104 #f)
(define %%%export-envframe-new~105 #f)
(define %%%export-env-lookup~106 #f)
(define %%%export-env-current-frame~107 #f)
(define %%%export-env-current-add-unknown!~108 #f)
(define %%%export-env-up/merge!~109 #f)
(define %%%export-env-new-envframe!~110 #f)
(define %%%export-env-new~111 #f)
(let ((id-primitive? %%%export-id-primitive?~93)
(id-aux-syntax? %%%export-id-aux-syntax?~92)
(id-macro? %%%export-id-macro?~91)
(id-variable? %%%export-id-variable?~90)
(id-library %%%export-id-library~89)
(id-gensym-ident %%%export-id-gensym-ident~88)
(id-global-name %%%export-id-global-name~87)
(id-source-name %%%export-id-source-name~86)
(id-set-library! %%%export-id-set-library!~85)
(id-set-gensym-ident! %%%export-id-set-gensym-ident!~84)
(id-set-global-name! %%%export-id-set-global-name!~83)
(id-new-aux-syntax %%%export-id-new-aux-syntax~82)
(id-new-primitive %%%export-id-new-primitive~81)
(id-new-library-macro %%%export-id-new-library-macro~80)
(id-new-library-variable %%%export-id-new-library-variable~79)
(id-new-macro %%%export-id-new-macro~78)
(id-new-variable %%%export-id-new-variable~77)
(id? %%%export-id?~76))
(define (%envframe-for-each proc envframe)
(for-each (lambda (sym+id) (proc sym+id)) (car envframe)))
(define (%envframe-filter-sym! envframe proc)
(define out '())
(let ((c (car envframe)))
(for-each
(lambda (sym+id)
(let ((sym (car sym+id)) (id (cdr sym+id)))
(let ((x (proc sym)))
(when x
(set! out (cons (cons (if (eq? x #t) sym x) id) out))))))
c)
(set-car! envframe (reverse out))))
(define (envframe-only-bindings! envframe . sym)
(define (filt s) (and (memv s sym) #t))
(%envframe-filter-sym! envframe filt))
(define (envframe-except-bindings! envframe . sym)
(define (filt s) (not (memv s sym)))
(%envframe-filter-sym! envframe filt))
(define (envframe-prefix-bindings! envframe pref)
(define name (symbol->string pref))
(define (filt s)
(string->symbol (string-append name (symbol->string s))))
(%envframe-filter-sym! envframe filt))
(define (envframe-rename-bindings! envframe . ren)
(define (filt s)
(define (itr rest)
(and (pair? rest)
(let ((from (car (car rest))) (to (cadr (car rest))))
(or (and (eq? from s) to) (itr (cdr rest))))))
(or (itr ren) s))
(%envframe-filter-sym! envframe filt))
(define (envframe-decl-binding! envframe sym id)
(let ((c (car envframe)))
(set-car! envframe (cons (cons (cons 'decl sym) id) c))))
(define (envframe-def-binding! envframe sym id)
(let ((c (car envframe)))
(set-car! envframe (cons (cons (cons 'def sym) id) c))))
(define (envframe-add-binding! envframe sym id)
(let ((c (car envframe))) (set-car! envframe (cons (cons sym id) c))))
(define (%envframe-lookup-tagged envframe tag sym)
(define (search rest)
(and (pair? rest)
(let ((p (caar rest)))
(or (and (pair? p)
(eq? (car p) tag)
(eq? (cdr p) sym)
(cdar rest))
(search (cdr rest))))))
(let ((l (car envframe))) (search l)))
(define (envframe-lookup-decl envframe sym)
(%envframe-lookup-tagged envframe 'decl sym))
(define (envframe-lookup-def envframe sym)
(%envframe-lookup-tagged envframe 'def sym))
(define (envframe-lookup envframe sym)
(define (search rest)
(and (pair? rest)
(or (and (eq? (caar rest) sym) (cdar rest))
(search (cdr rest)))))
(let ((l (car envframe))) (search l)))
(define (envframe-import! envframe libframe)
(define (importone e)
(let ((sym (car e)) (id (cdr e)))
(let ((origid (envframe-lookup envframe sym)))
(cond (origid
(unless (and (eq? (id-source-name origid)
(id-source-name id))
(eq? (id-global-name origid)
(id-global-name id))
(equal? (id-library origid) (id-library id)))
(error "Unmatched import" origid id)))
(else (envframe-add-binding! envframe sym id))))))
(let ((l (car libframe))) (for-each importone l)))
(define (envframe-new) (cons '() #f))
(define (%env-content env) (car env))
(define (%env-content-set! env e) (set-car! env e))
(define (%env-capsule l) (cons l #f))
(define (env-lookup env sym)
(define (search rest)
(and (pair? rest)
(or (envframe-lookup (env-current-frame (%env-capsule rest)) sym)
(search (cdr rest)))))
(search (%env-content env)))
(define (env-current-frame env) (caar (%env-content env)))
(define (env-current-add-unknown! env pair)
(let ((p (car (%env-content env))))
(let ((current-unknown (cdr p)))
(set-cdr! p (cons pair current-unknown)))))
(define (%env-current-unknown-reset! env)
(let ((p (car (%env-content env)))) (set-cdr! p '())))
(define (env-up/merge! env)
(let ((unknowns (cdar (cdr (%env-content env))))
(cf (env-current-frame env))
(next (cdr (%env-content env))))
(let ((next-env (%env-capsule next)))
(%envframe-for-each
(lambda (x+id)
(let ((x (car x+id)) (id (cdr x+id)))
(when (pair? x)
(let ((disp (car x)) (sym (cdr x)))
(when (eq? disp 'def)
(envframe-add-binding!
(env-current-frame next-env)
sym
id))))))
cf)
(%env-current-unknown-reset! next-env)
(for-each
(lambda (e)
(let ((id (env-lookup next-env (car e))))
(cond (id
(unless (id-variable? id) (error "Invalid def match" e))
(set-car! e (id-global-name id)))
(else (env-current-add-unknown! next-env e)))))
unknowns))
(%env-content-set! env next)))
(define (env-new-envframe! env)
(let ((c (%env-content env)))
(%env-content-set! env (cons (cons (envframe-new) '()) c))))
(define (env-new) (%env-capsule (list (cons (envframe-new) '()))))
(set! %%%export-envframe-decl-binding!~94 envframe-decl-binding!)
(set! %%%export-envframe-def-binding!~95 envframe-def-binding!)
(set! %%%export-envframe-add-binding!~96 envframe-add-binding!)
(set! %%%export-envframe-only-bindings!~97 envframe-only-bindings!)
(set! %%%export-envframe-except-bindings!~98 envframe-except-bindings!)
(set! %%%export-envframe-prefix-bindings!~99 envframe-prefix-bindings!)
(set! %%%export-envframe-rename-bindings!~100 envframe-rename-bindings!)
(set! %%%export-envframe-lookup~101 envframe-lookup)
(set! %%%export-envframe-lookup-decl~102 envframe-lookup-decl)
(set! %%%export-envframe-lookup-def~103 envframe-lookup-def)
(set! %%%export-envframe-import!~104 envframe-import!)
(set! %%%export-envframe-new~105 envframe-new)
(set! %%%export-env-lookup~106 env-lookup)
(set! %%%export-env-current-frame~107 env-current-frame)
(set! %%%export-env-current-add-unknown!~108 env-current-add-unknown!)
(set! %%%export-env-up/merge!~109 env-up/merge!)
(set! %%%export-env-new-envframe!~110 env-new-envframe!)
(set! %%%export-env-new~111 env-new)))
(begin
(define %%%export-interfacelib~112 #f)
(define %%%export-id-$define/primitive?~113 #f)
(define %%%export-id-$define-aux-syntax?~114 #f)
(define %%%export-id-$bind-variable?~115 #f)
(define %%%export-id-$bind-definition?~116 #f)
(define %%%export-id-$extend-env?~117 #f)
(define %%%export-id-$inject?~118 #f)
(define %%%export-id-$inject/multi?~119 #f)
(define %%%export-id-$inject/form?~120 #f)
(define %%%export-id-$inject/splice?~121 #f)
(define %%%export-id-$alias?~122 #f)
(define %%%export-id-$quote?~123 #f)
(define %%%export-id-define-syntax?~124 #f)
(define %%%export-id-syntax-error?~125 #f)
(define %%%export-id-syntax-rules?~126 #f)
(let ((env-new %%%export-env-new~111)
(env-new-envframe! %%%export-env-new-envframe!~110)
(env-up/merge! %%%export-env-up/merge!~109)
(env-current-add-unknown! %%%export-env-current-add-unknown!~108)
(env-current-frame %%%export-env-current-frame~107)
(env-lookup %%%export-env-lookup~106)
(envframe-new %%%export-envframe-new~105)
(envframe-import! %%%export-envframe-import!~104)
(envframe-lookup-def %%%export-envframe-lookup-def~103)
(envframe-lookup-decl %%%export-envframe-lookup-decl~102)
(envframe-lookup %%%export-envframe-lookup~101)
(envframe-rename-bindings! %%%export-envframe-rename-bindings!~100)
(envframe-prefix-bindings! %%%export-envframe-prefix-bindings!~99)
(envframe-except-bindings! %%%export-envframe-except-bindings!~98)
(envframe-only-bindings! %%%export-envframe-only-bindings!~97)
(envframe-add-binding! %%%export-envframe-add-binding!~96)
(envframe-def-binding! %%%export-envframe-def-binding!~95)
(envframe-decl-binding! %%%export-envframe-decl-binding!~94)
(id-primitive? %%%export-id-primitive?~93)
(id-aux-syntax? %%%export-id-aux-syntax?~92)
(id-macro? %%%export-id-macro?~91)
(id-variable? %%%export-id-variable?~90)
(id-library %%%export-id-library~89)
(id-gensym-ident %%%export-id-gensym-ident~88)
(id-global-name %%%export-id-global-name~87)
(id-source-name %%%export-id-source-name~86)
(id-set-library! %%%export-id-set-library!~85)
(id-set-gensym-ident! %%%export-id-set-gensym-ident!~84)
(id-set-global-name! %%%export-id-set-global-name!~83)
(id-new-aux-syntax %%%export-id-new-aux-syntax~82)
(id-new-primitive %%%export-id-new-primitive~81)
(id-new-library-macro %%%export-id-new-library-macro~80)
(id-new-library-variable %%%export-id-new-library-variable~79)
(id-new-macro %%%export-id-new-macro~78)
(id-new-variable %%%export-id-new-variable~77)
(id? %%%export-id?~76))
(define lib '(r7c-expander-interface))
(define-syntax
xid
(syntax-rules () ((_ sym) (id-new-library-macro 'sym 'sym lib))))
(define %$define/primitive (xid $define/primitive))
(define %$define-aux-syntax (xid $define-aux-syntax))
(define %$bind-variable (xid $bind-variable))
(define %$bind-definition (xid $bind-definition))
(define %$extend-env (xid $extend-env))
(define %$inject (xid $inject))
(define %$inject/splice (xid $inject/splice))
(define %$inject/multi (xid $inject/multi))
(define %$inject/form (xid $inject/form))
(define %$alias (xid $alias))
(define %$quote (xid $quote))
(define %define-syntax (xid define-syntax))
(define %syntax-rules (xid syntax-rules))
(define %syntax-error (xid syntax-error))
(define (id-$define/primitive? x) (eq? x %$define/primitive))
(define (id-$define-aux-syntax? x) (eq? x %$define-aux-syntax))
(define (id-$bind-variable? x) (eq? x %$bind-variable))
(define (id-$bind-definition? x) (eq? x %$bind-definition))
(define (id-$extend-env? x) (eq? x %$extend-env))
(define (id-$inject? x) (eq? x %$inject))
(define (id-$inject/splice? x) (eq? x %$inject/splice))
(define (id-$inject/multi? x) (eq? x %$inject/multi))
(define (id-$inject/form? x) (eq? x %$inject/form))
(define (id-$alias? x) (eq? x %$alias))
(define (id-$quote? x) (eq? x %$quote))
(define (id-define-syntax? x) (eq? x %define-syntax))
(define (id-syntax-rules? x) (eq? x %syntax-rules))
(define (id-syntax-error? x) (eq? x %syntax-error))
(define (libs)
(let ((ef (envframe-new)))
(for-each
(lambda (s e) (envframe-add-binding! ef s e))
'($define/primitive
$define-aux-syntax
$bind-variable
$bind-definition
$extend-env
$inject
$inject/splice
$inject/multi
$inject/form
$alias
$quote
define-syntax
syntax-rules
syntax-error)
(list %$define/primitive
%$define-aux-syntax
%$bind-variable
%$bind-definition
%$extend-env
%$inject
%$inject/splice
%$inject/multi
%$inject/form
%$alias
%$quote
%define-syntax
%syntax-rules
%syntax-error))
ef))
(define (interfacelib) (cons lib (libs)))
(set! %%%export-interfacelib~112 interfacelib)
(set! %%%export-id-$define/primitive?~113 id-$define/primitive?)
(set! %%%export-id-$define-aux-syntax?~114 id-$define-aux-syntax?)
(set! %%%export-id-$bind-variable?~115 id-$bind-variable?)
(set! %%%export-id-$bind-definition?~116 id-$bind-definition?)
(set! %%%export-id-$extend-env?~117 id-$extend-env?)
(set! %%%export-id-$inject?~118 id-$inject?)
(set! %%%export-id-$inject/multi?~119 id-$inject/multi?)
(set! %%%export-id-$inject/form?~120 id-$inject/form?)
(set! %%%export-id-$inject/splice?~121 id-$inject/splice?)
(set! %%%export-id-$alias?~122 id-$alias?)
(set! %%%export-id-$quote?~123 id-$quote?)
(set! %%%export-id-define-syntax?~124 id-define-syntax?)
(set! %%%export-id-syntax-error?~125 id-syntax-error?)
(set! %%%export-id-syntax-rules?~126 id-syntax-rules?)))
(begin
(define %%%export-expand-forms!~127 #f)
(let ((id-syntax-rules? %%%export-id-syntax-rules?~126)
(id-syntax-error? %%%export-id-syntax-error?~125)
(id-define-syntax? %%%export-id-define-syntax?~124)
(id-$quote? %%%export-id-$quote?~123)
(id-$alias? %%%export-id-$alias?~122)
(id-$inject/splice? %%%export-id-$inject/splice?~121)
(id-$inject/form? %%%export-id-$inject/form?~120)
(id-$inject/multi? %%%export-id-$inject/multi?~119)
(id-$inject? %%%export-id-$inject?~118)
(id-$extend-env? %%%export-id-$extend-env?~117)
(id-$bind-definition? %%%export-id-$bind-definition?~116)
(id-$bind-variable? %%%export-id-$bind-variable?~115)
(id-$define-aux-syntax? %%%export-id-$define-aux-syntax?~114)
(id-$define/primitive? %%%export-id-$define/primitive?~113)
(interfacelib %%%export-interfacelib~112)
(env-new %%%export-env-new~111)
(env-new-envframe! %%%export-env-new-envframe!~110)
(env-up/merge! %%%export-env-up/merge!~109)
(env-current-add-unknown! %%%export-env-current-add-unknown!~108)
(env-current-frame %%%export-env-current-frame~107)
(env-lookup %%%export-env-lookup~106)
(envframe-new %%%export-envframe-new~105)
(envframe-import! %%%export-envframe-import!~104)
(envframe-lookup-def %%%export-envframe-lookup-def~103)
(envframe-lookup-decl %%%export-envframe-lookup-decl~102)
(envframe-lookup %%%export-envframe-lookup~101)
(envframe-rename-bindings! %%%export-envframe-rename-bindings!~100)
(envframe-prefix-bindings! %%%export-envframe-prefix-bindings!~99)
(envframe-except-bindings! %%%export-envframe-except-bindings!~98)
(envframe-only-bindings! %%%export-envframe-only-bindings!~97)
(envframe-add-binding! %%%export-envframe-add-binding!~96)
(envframe-def-binding! %%%export-envframe-def-binding!~95)
(envframe-decl-binding! %%%export-envframe-decl-binding!~94)
(id-primitive? %%%export-id-primitive?~93)
(id-aux-syntax? %%%export-id-aux-syntax?~92)
(id-macro? %%%export-id-macro?~91)
(id-variable? %%%export-id-variable?~90)
(id-library %%%export-id-library~89)
(id-gensym-ident %%%export-id-gensym-ident~88)
(id-global-name %%%export-id-global-name~87)
(id-source-name %%%export-id-source-name~86)
(id-set-library! %%%export-id-set-library!~85)
(id-set-gensym-ident! %%%export-id-set-gensym-ident!~84)
(id-set-global-name! %%%export-id-set-global-name!~83)
(id-new-aux-syntax %%%export-id-new-aux-syntax~82)
(id-new-primitive %%%export-id-new-primitive~81)
(id-new-library-macro %%%export-id-new-library-macro~80)
(id-new-library-variable %%%export-id-new-library-variable~79)
(id-new-macro %%%export-id-new-macro~78)
(id-new-variable %%%export-id-new-variable~77)
(id? %%%export-id?~76))
(define (expand! top-level? forms env cb-gensym)
(define (re-enter) (expand! top-level? forms env cb-gensym))
(define (next) (expand! top-level? (cdr forms) env cb-gensym))
(define (enter p) (expand! top-level? p env cb-gensym))
(define (gensym p orig) (cb-gensym p orig top-level?))
(define (erase-next)
(let ((d (cdr forms)))
(cond ((pair? d)
(set-car! forms (car d))
(set-cdr! forms (cdr d))
(re-enter))
((null? d) (set-car! forms '(begin)))
(else (error "oops" forms)))))
(define (expand-car! maybe-macro? thepair env)
(define (handle-variable lookup)
(set-car! thepair (id-global-name lookup)))
(define (handle-unknown) (env-current-add-unknown! env thepair))
(unless (pair? thepair) (error "pair required" thepair))
(let ((a (car thepair)))
(cond ((symbol? a)
(let ((lookup (env-lookup env a)))
(cond (maybe-macro?
(cond ((and lookup (id-macro? lookup))
(set-car! thepair lookup))
(lookup (handle-variable lookup))
(else (handle-unknown))))
(lookup
(when (id-macro? lookup)
(error "macro not allowed here" thepair))
(handle-variable lookup))
(else (handle-unknown))))))))
(define (expand-variable! top-level? forms env)
(unless (or (pair? forms) (null? forms)) (error "huh?" forms))
(when (pair? forms)
(let ((a (car forms)))
(cond ((pair? a) (expand! top-level? forms env cb-gensym))
(else
(expand-car! #f forms env)
(expand-variable! top-level? (cdr forms) env))))))
(define (expand-$inject splice-env? multi-env? forms a)
(define new-frame? (not (or splice-env? multi-env?)))
(let ((sym (cadr a)) (body* (cddr a)))
(when new-frame? (env-new-envframe! env))
(expand! (and splice-env? top-level?) body* env cb-gensym)
(when new-frame? (env-up/merge! env))
(set-car! forms (cdr a))
(next)))
(define (expand-$inject/form forms a)
(let ((body* (cdr a)))
(expand! top-level? body* env cb-gensym)
(set-car! forms body*)))
(cond ((pair? forms)
(let ((a (car forms)))
(cond ((pair? a)
(let ((i (car a)))
(cond ((symbol? i)
(expand-car! #t a env)
(let ((i2 (car a)))
(cond ((symbol? i2)
(expand-variable!
top-level?
(cdr a)
env)
(next))
(else (re-enter)))))
((pair? i) (enter a) (next))
((not (id? i)) (error "Invalid invocation" a))
((id-$bind-variable? i)
(let ((sym (cadr a)))
(unless (symbol? sym)
(error "symbol required" a))
(envframe-decl-binding!
(env-current-frame env)
sym
(id-new-variable sym))
(set-car! forms sym)
(next)))
((id-$bind-definition? i)
(let ((sym (cadr a)))
(unless (symbol? sym)
(error "symbol required" a))
(let ((id (id-new-variable sym))
(gsym (gensym a sym)))
(id-set-global-name! id gsym)
(envframe-def-binding!
(env-current-frame env)
sym
id)
(set-car! forms gsym)
(next))))
((id-$extend-env? i)
(let ((sym* (cadr a)) (body* (cddr a)))
(let ((cf (env-current-frame env)))
(for-each
(lambda (sym)
(or (let ((decl (envframe-lookup-decl
cf
sym)))
(and decl
(begin
(envframe-add-binding!
cf
sym
decl)
#t)))
(let ((def (envframe-lookup-def
cf
sym)))
(and def
(begin
(envframe-add-binding!
cf
sym
def)
#t)))
(begin
(envframe-add-binding!
cf
sym
(id-new-variable sym)))))
sym*))
(expand! #f body* env cb-gensym)
(letrec* ((go-last (lambda (p)
(let ((b (cdr p)))
(cond ((null? b) p)
((pair? b)
(go-last b))
(else
(error "dotted $extend-env??"
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
a))))))
;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
(lastpair (go-last body*)))
(let ((d (cdr forms)))
(set-car! forms (car body*))
(set-cdr! forms (cdr body*))
(set-cdr! lastpair d)
(enter d)))))
((id-$define/primitive? i)
(let ((sym (cadr a)))
(envframe-add-binding!
(env-current-frame env)
sym
(id-new-primitive sym sym #f)))
(erase-next))
((id-$define-aux-syntax? i)
(let ((sym (cadr a)))
(envframe-add-binding!
(env-current-frame env)
sym
(id-new-aux-syntax sym #f)))
(erase-next))
((id-$inject? i) (expand-$inject #f #f forms a))
((id-$inject/splice? i)
(expand-$inject #t #f forms a))
((id-$inject/multi? i)
(expand-$inject #f #t forms a))
((id-$inject/form? i)
(expand-$inject/form forms a))
((id-$alias? i)
(let ((sym1 (cadr a)) (sym2 (cadr (cdr a))))
(let ((b (env-lookup env sym1)))
(unless b
(error "cannot find id for alias"
a))
(envframe-add-binding!
(env-current-frame env)
sym2
b)))
(erase-next))
((id-$quote? i)
(set-car! forms (cadr a))
(next))
((id-define-syntax? i)
(error "IMPLEMENT ME!")
(next))
((id-syntax-rules? i)
(error "syntax-rules outside define-syntax" a)
(next))
((id-syntax-error? i)
(error "Syntax error" a)
(next))
((id-macro? i) (error "IMPLEMENT ME!") (next))
((id-variable? i)
(expand-car! #t a env)
(re-enter))
(else (error "Unknown identifier" a)))))
(else (expand-car! #f forms env) (next)))))
((not (null? forms))
(error "invalid top-level from (dotted-program???)" forms))))
(define (expand-forms! forms env cb-gensym)
(cond ((pair? forms) (expand! #t forms env cb-gensym))
((not (null? forms)) (error "invalid program format" forms))))
(set! %%%export-expand-forms!~127 expand-forms!)))
(begin
(define expand-forms! %%%export-expand-forms!~127)
(define id-syntax-rules? %%%export-id-syntax-rules?~126)
(define id-syntax-error? %%%export-id-syntax-error?~125)
(define id-define-syntax? %%%export-id-define-syntax?~124)
(define id-$quote? %%%export-id-$quote?~123)
(define id-$alias? %%%export-id-$alias?~122)
(define id-$inject/splice? %%%export-id-$inject/splice?~121)
(define id-$inject/form? %%%export-id-$inject/form?~120)
(define id-$inject/multi? %%%export-id-$inject/multi?~119)
(define id-$inject? %%%export-id-$inject?~118)
(define id-$extend-env? %%%export-id-$extend-env?~117)
(define id-$bind-definition? %%%export-id-$bind-definition?~116)
(define id-$bind-variable? %%%export-id-$bind-variable?~115)
(define id-$define-aux-syntax? %%%export-id-$define-aux-syntax?~114)
(define id-$define/primitive? %%%export-id-$define/primitive?~113)
(define interfacelib %%%export-interfacelib~112)
(define env-new %%%export-env-new~111)
(define env-new-envframe! %%%export-env-new-envframe!~110)
(define env-up/merge! %%%export-env-up/merge!~109)
(define env-current-add-unknown! %%%export-env-current-add-unknown!~108)
(define env-current-frame %%%export-env-current-frame~107)
(define env-lookup %%%export-env-lookup~106)
(define envframe-new %%%export-envframe-new~105)
(define envframe-import! %%%export-envframe-import!~104)
(define envframe-lookup-def %%%export-envframe-lookup-def~103)
(define envframe-lookup-decl %%%export-envframe-lookup-decl~102)
(define envframe-lookup %%%export-envframe-lookup~101)
(define envframe-rename-bindings! %%%export-envframe-rename-bindings!~100)
(define envframe-prefix-bindings! %%%export-envframe-prefix-bindings!~99)
(define envframe-except-bindings! %%%export-envframe-except-bindings!~98)
(define envframe-only-bindings! %%%export-envframe-only-bindings!~97)
(define envframe-add-binding! %%%export-envframe-add-binding!~96)
(define envframe-def-binding! %%%export-envframe-def-binding!~95)
(define envframe-decl-binding! %%%export-envframe-decl-binding!~94)
(define utf8-read %%%export-utf8-read~75)
(define failure->string %%%export-failure->string~26)
(define failure? %%%export-failure?~25)
(define testeval %%%export-testeval~24)
(define test-counter 0)
(define success-counter 0)
(define failed-forms '())
(define (check-finish)
(display "Test: ")
(display success-counter)
(display "/")
(display test-counter)
(display " passed.")
(newline)
(unless (null? failed-forms)
(newline)
(display "Failed: ")
(newline)
(for-each
(lambda x (display " ") (write x) (newline))
(reverse failed-forms)))
(flush-output-port (current-output-port))
(exit (if (null? failed-forms) 0 1)))
(define-syntax
check-equal
(syntax-rules
()
((_ obj form)
(begin
(set! test-counter (+ 1 test-counter))
(let ((e form))
(cond ((equal? obj e) (set! success-counter (+ 1 success-counter)))
(else (set! failed-forms (cons 'form failed-forms)))))))))
(check-equal 10 (match '(1 10 11) ((a b c) b)))
(define (test-minife sexp)
(define cnt 0)
(define (copy-sexp sexp)
(cond ((pair? sexp)
(cons (copy-sexp (car sexp)) (copy-sexp (cdr sexp))))
(else sexp)))
(define (gensym pair symname global?)
(set! cnt (+ 1 cnt))
(string->symbol
(string-append (symbol->string symname) "_" (number->string cnt))))
(let ((xlib (interfacelib)) (xenv (env-new)) (forms (copy-sexp sexp)))
(envframe-import! (env-current-frame xenv) (cdr xlib))
(expand-forms! forms xenv gensym)
forms))
(define-syntax
check-minife
(syntax-rules () ((_ frm ex) (check-equal 'ex (test-minife 'frm)))))
(check-minife ((hello)) ((hello)))
(check-minife (($define/primitive a)) ((begin)))
(check-minife (($define-aux-syntax a)) ((begin)))
(check-minife (($define/primitive a) 1 2 3) (1 2 3))
(check-minife (($define-aux-syntax a) 1 2 3) (1 2 3))
(check-minife (($bind-variable hoge)) (hoge))
(check-minife (($bind-definition hoge)) (hoge_1))
(check-minife (($extend-env () a b c)) (a b c))
(check-minife (($inject hoge)) ((hoge)))
(check-minife (($inject hoge a b c)) ((hoge a b c)))
(check-minife (($inject hoge a b c 1234 "hoge")) ((hoge a b c 1234 "hoge")))
(check-minife (($inject/splice hoge)) ((hoge)))
(check-minife (($inject/splice hoge a b c)) ((hoge a b c)))
(check-minife (($inject/form hoge a b c)) ((hoge a b c)))
(check-minife (($quote hoge)) (hoge))
(check-minife (($quote (hoge 1 2 3))) ((hoge 1 2 3)))
(check-minife (($extend-env (a) ($alias a b) b)) (a))
(check-minife
(($inject def ($bind-definition abc) ($extend-env (abc) a abc)) abc)
((def abc_1 a abc_1) abc_1))
(check-minife
(($inject def
($bind-definition abc)
($extend-env (abc) ($inject let ($extend-env (abc) abc)) abc)))
((def abc_1 (let abc) abc_1)))
(define* testtype (entry-a entry-b))
(define* testtype2 (entry-a entry-b))
(define testobj0 (make testtype (entry-a 10)))
(begin
(check-equal #t (is-a? testobj0 testtype))
(check-equal #f (is-a? testobj0 testtype2))
(check-equal 10 (~ testobj0 'entry-a))
(~ testobj0 'entry-a := 1)
(check-equal 1 (~ testobj0 'entry-a))
(~ testobj0 'entry-b := 2)
(check-equal 2 (~ testobj0 'entry-b))
(touch! testobj0 (entry-a 'a) (entry-b 'b))
(let-with
testobj0
(entry-a entry-b)
(check-equal 'a entry-a)
(check-equal 'b entry-b)))
(define (testfunc . param)
(match param
(('ref slot obj) (check-equal 'testme slot) (cdr obj))
(('set! slot obj v) (check-equal 'testme slot) (set-cdr! obj v))))
(define-minidispatch-class testclass testfunc)
(define obj0 (make-minidispatch-obj testclass (cons #t #t)))
(~ obj0 'testme := "hoge")
(check-equal "hoge" (~ obj0 'testme))
(let-with obj0 (testme) (check-equal "hoge" testme))
(check-equal #t (is-a? obj0 testclass))
(define dispatch0
(dispatch-lambda
(('pass1 x) (check-equal x 1) "OKAY")
(('pass1alt x) (check-equal x 2) "OKAYalt")
(('pass2-2 x y) (check-equal x 2) (check-equal y 2) "OKAY")
(('passnone) "OKAY")
((pass str)
(check-equal #t (string? pass))
(check-equal #t (string? str))
"OKAY")))
(check-equal "OKAY" (dispatch0 'pass1 1))
(check-equal "OKAYalt" (dispatch0 'pass1alt 2))
(check-equal "OKAY" (dispatch0 'pass2-2 2 2))
(check-equal "OKAY" (dispatch0 'passnone))
(check-equal "OKAY" (dispatch0 "str" "str"))
(define (equal-check-deep sexp0 sexp1)
(define (comp ctx s0 s1)
(cond ((pair? s0)
(if (pair? s1)
(and (comp (cons s0 ctx) (car s0) (car s1))
(comp (cons s0 ctx) (cdr s0) (cdr s0)))
(error "pair-unmatch!" s0 s1)))
(else
(let ((e (equal? s0 s1)))
(unless e (error "datum-unmatch!" ctx (list s0 s1)))
e))))
(check-equal #t (comp '() sexp0 sexp1)))
(define (port->sexp p)
(define (itr cur)
(let ((r (read p)))
(if (eof-object? r) (reverse cur) (itr (cons r cur)))))
(itr '()))
(define (file->sexp pth)
(define p (open-input-file pth))
(let ((obj (port->sexp p))) (close-port p) obj))
(define (textfile->bytevector pth)
(define p (open-input-file pth))
(define (itr cur)
(let ((l (read-line p)))
(if (eof-object? l)
(string->utf8 cur)
(itr (if (string=? "" cur) l (string-append cur "\n" l))))))
(itr ""))
(define (verify-file pth)
(let ((x (file->sexp pth)) (y (utf8-read (textfile->bytevector pth))))
(equal-check-deep x y)))
(define yuni-compat-libs
(begin
(unless (file-exists? "_testing_liblist.txt")
(error "_testing_liblist.txt was not found. Generate it with CMake first."))
(let ((p (open-input-file "_testing_liblist.txt")))
(define (itr cur)
(let ((l (read-line p)))
(if (eof-object? l) cur (itr (cons l cur)))))
(itr '()))))
(define test-files
(append yuni-compat-libs '("_sanity.sps" "_ncccsanity.sps")))
(define (miniread-tests)
(define (checkobj str obj)
(let* ((bv (string->utf8 str)) (obj1 (utf8-read bv)))
(check-equal obj1 obj)))
(define (check str)
(let* ((p (open-input-string str)) (obj0 (port->sexp p)))
(checkobj str obj0)))
(define-syntax
check2
(syntax-rules
()
((_ obj ...)
(let* ((p (open-output-string))
(gen (lambda (e) (write e p) (display " " p))))
(for-each gen '(obj ...))
(let* ((str (get-output-string p))
(bv (string->utf8 str))
(obj1 (utf8-read bv)))
(check-equal obj1 '(obj ...)))))))
(check "#| # |# hoge")
(check2 a)
(check2 a b c d)
(check2 #\a "hoge")
(check2 "\"")
(check2 "hoge" "hoge")
(check2 "hoge" fuga "hoge")
(check2 ("hoge\"" fuga "\"hoge"))
(check "`(hoge ,fuga)")
(check "`(hoge ,@fuga)")
(check "a b c")
(check "#\\a")
(check "#;(hoge) fuga")
(check "#| hoge |# fuga")
(check ";; fuga\nhoge")
(check "(100 () (1 2 3) 100)")
(check "'abc")
(check ",abc")
(check ",()")
(check ",(,abc)")
(check ",(,@abc)")
(check "100\n")
(check "")
(check "100")
(check "(100 100)")
(check "(\"ABC\")")
(check "(100 \"ABC\")")
(check "#(100 100)")
(check "#()")
(checkobj "#vu8(1 2 3 4)" (list (bytevector 1 2 3 4)))
(checkobj "#u8(1 2 3 4)" (list (bytevector 1 2 3 4)))
(checkobj "#u8()" (list (bytevector)))
(checkobj "#vu8(0)" (list (bytevector 0))))
(miniread-tests)
(for-each verify-file test-files)
(check-finish)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment