diff options
Diffstat (limited to 'derived/text-binary.scm')
| -rw-r--r-- | derived/text-binary.scm | 228 |
1 files changed, 228 insertions, 0 deletions
diff --git a/derived/text-binary.scm b/derived/text-binary.scm new file mode 100644 index 0000000..1779d1a --- /dev/null +++ b/derived/text-binary.scm @@ -0,0 +1,228 @@ +;;; ---------------------------------------------------------------- +;;; Text +;;; ---------------------------------------------------------------- + +(define (text-fns algdata suppress-reader?) + (let ((print+read + (cond ((algdata-enum? algdata) + (text-enum-fns algdata)) + (else + (text-general-fns algdata))))) + (when suppress-reader? + (setf print+read (list (car print+read)))) + print+read)) + +(define (text-enum-fns algdata) + (list + (**define '|showsPrec| '(|d| |x|) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (declare (ignore vars)) + (**showString (**string (con-string con)))))) + (**define '|readsPrec| '(|d| |str|) + (**listcomp + (**var '|s|) + (list + (**gen '(tuple |tok| |rest|) (**lex (**var '|str|))) + (**gen '|s| + (**case (**var '|tok|) + `(,@(map (lambda (con) + (**alt/simple + (**pat (con-string con)) + (**list (**tuple2 (**con/def con) + (**var '|rest|))))) + (algdata-constrs algdata)) + ,(**alt/simple (**pat '_) (**null)))))))))) + +;;; This has been hacked to split up the read function for large +;;; data types to avoid choking the lisp compiler. + +(define (text-general-fns algdata) + (let ((split-fn-def? (> (algdata-n-constr algdata) 6))) ;; pretty arbitrary! + (list + (**define '|showsPrec| '(|d| |x|) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (if (con-infix? con) + (show-infix con vars) + (show-prefix con vars))))) + (**define '|readsPrec| '(|d| |str|) + (**append/l + (map (lambda (con) + (cond ((con-infix? con) + (read-infix con)) + (else + (read-prefix con split-fn-def?)))) + (algdata-constrs algdata))))))) + +(define (show-infix con vars) + (multiple-value-bind (p lp rp) (get-con-fixity con) + (**showParen + (**< (**Int p) (**var '|d|)) + (**dot (**showsPrec (**int lp) (**var (car vars))) + (**showString + (**string (string-append " " (con-string con) " "))) + (**showsPrec (**int rp) (**var (cadr vars))))))) + +(define (show-prefix con vars) + (**showParen + (**<= (**int 10) (**var '|d|)) + (**dot/l (**showString (**string (con-string con))) + (show-fields vars)))) + +(define (show-fields vars) + (if (null? vars) + '() + `(,(**space) ,(**showsPrec (**int 10) (**var (car vars))) + ,@(show-fields (cdr vars))))) + +(define (read-infix con) + (multiple-value-bind (p lp rp) (get-con-fixity con) + (**let + (list + (**define '|readVal| '(|r|) + (**listcomp + (**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|)) + (**var '|s2|)) + (list + (**gen '(tuple |u| |s0|) + (**readsPrec (**int lp) (**var '|r|))) + (**gen `(tuple ,(con-string con) |s1|) + (**lex (**var '|s0|))) + (**gen '(tuple |v| |s2|) + (**readsprec (**int rp) (**var '|s1|))))))) + (**readParen (**< (**int p) (**var '|d|)) + (**var '|readVal|) (**var '|str|))))) + +(define (read-prefix con split?) + (let ((res (read-prefix-1 con))) + (if (not split?) + res + (dynamic-let ((*module-name* (def-module con))) + (dynamic-let ((*module* (table-entry *modules* *module-name*))) + (let* ((alg (con-alg con)) + (fn (make-new-var + (string-append (symbol->string (def-name alg)) + "/read-" + (remove-con-prefix + (symbol->string (def-name con)))))) + (new-code (**app (**var/def fn) (**var '|str|) (**var '|d|))) + (def (**define fn '(|str| |d|) res))) + (setf (module-decls *module*) (cons def (module-decls *module*))) + new-code)))))) + +(define (read-prefix-1 con) + (let* ((arity (con-arity con)) + (vars (temp-vars "x" arity)) + (svars (cons '|rest| (temp-vars "s" arity)))) + (**let + (list + (**define '|readVal| '(|r|) + (**listcomp + (**tuple2 (**app/l (**con/def con) (map (function **var) vars)) + (**var (car (reverse svars)))) + (cons + (**gen `(tuple ,(con-string con) |rest|) + (**lex (**var '|r|))) + (read-fields vars svars (cdr svars)))))) + (**readParen (**< (**int 9) (**var '|d|)) + (**var '|readVal|) (**var '|str|))))) + +(define (read-fields vars s0 s1) + (if (null? vars) + '() + (cons + (**gen `(tuple ,(car vars) ,(car s1)) + (**readsprec (**int 10) (**var (car s0)))) + (read-fields (cdr vars) (cdr s0) (cdr s1))))) + + +;;; ---------------------------------------------------------------- +;;; Binary +;;; ---------------------------------------------------------------- + +(define (binary-fns algdata) + (let ((res + (cond ((algdata-enum? algdata) + (binary-enum-fns algdata)) + ((algdata-tuple? algdata) + (binary-tuple-fns algdata)) + (else + (binary-general-fns algdata))))) +; (dolist (x res) +; (fresh-line) +; (pprint x)) + res)) + + +(define (binary-enum-fns algdata) + (list + (**define '|showBin| '(|x| |b|) + (**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|))) + (**define '|readBin| '(|b|) + (**let + (list + (**define '(tuple |n| |b1|) '() + (**readBinSmallInt + (**var '|b|) + (**int (1- (algdata-n-constr algdata)))))) + (**tuple2 + (**case/int algdata (**var '|n|) + (lambda (con) + (**con/def con))) + (**var '|b1|)))))) + +(define (binary-tuple-fns algdata) + (let* ((con (tuple-con algdata)) + (arity (con-arity con)) + (vars (temp-vars "v" arity))) + (list + (**define '|showBin| `((,con ,@vars) |b|) + (show-binary-body vars '|b|)) + (**define '|readBin| '(|b|) + (read-binary-body con))))) + +(define (show-binary-body vars b) + (**foldr (lambda (new-term prev-terms) + (**showBin new-term prev-terms)) + (map (function **var) vars) + (**var b))) + +(define (read-binary-body con) + (let* ((arity (con-arity con)) + (vars (temp-vars "v" arity)) + (bvars (cons '|b| (temp-vars "b" arity)))) + (**let + (map (lambda (v b nb) + (**define `(tuple ,v ,nb) '() + (**readBin (**var b)))) + vars bvars (cdr bvars)) + (**tuple2 + (**app/l (**con/def con) + (map (function **var) vars)) + (**var (car (reverse bvars))))))) + +(define (binary-general-fns algdata) + (list + (**define '|showBin| '(|x| |b|) + (**showBinInt + (**con-number (**var '|x|) algdata) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (declare (ignore con)) + (show-binary-body vars '|b|))))) + (**define '|readBin| '(|bin|) + (**let + (list + (**define '(tuple |i| |b|) '() + (**readBinSmallInt (**var '|bin|) + (**int (1- (algdata-n-constr algdata)))))) + (**case/int algdata (**var '|i|) (function read-binary-body)))))) + +(define (get-con-fixity con) + (let ((fixity (con-fixity con))) + (if (not (eq? fixity '#f)) + (let ((p (fixity-precedence fixity)) + (a (fixity-associativity fixity))) + (values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p)))) + (values 9 10 9)))) |