From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- derived/ast-builders.scm | 273 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 273 insertions(+) create mode 100644 derived/ast-builders.scm (limited to 'derived/ast-builders.scm') diff --git a/derived/ast-builders.scm b/derived/ast-builders.scm new file mode 100644 index 0000000..3a16ee6 --- /dev/null +++ b/derived/ast-builders.scm @@ -0,0 +1,273 @@ +;;; These functions build non-trivial ast structure. + +;;; Prelude functions: booleans + +(define (**== e1 e2) + (**app (**var/def (core-symbol "==")) e1 e2)) + +(define (**<= e1 e2) + (**app (**var/def (core-symbol "<=")) e1 e2)) + +(define (**< e1 e2) + (**app (**var/def (core-symbol "<")) e1 e2)) + +(define (**> e1 e2) + (**app (**var/def (core-symbol ">")) e1 e2)) + +(define (**and e1 e2) + (**app (**var/def (core-symbol "&&")) e1 e2)) + +(define (**or e1 e2) + (**app (**var/def (core-symbol "||")) e1 e2)) + +(define (**true) (**con/def (core-symbol "True"))) + +(define (**false) (**con/def (core-symbol "False"))) + +;; Tuples + +(define (**tuple2 x y) + (**app (**con/def (tuple-constructor 2)) x y)) + +(define (**tupleN exps) + (**app/l (**con/def (tuple-constructor (length exps))) exps)) + +;; Arithmetic + +(define (**+ x y) + (**app (**var/def (core-symbol "+")) x y)) + +(define (**+/Int x y) + (**app (**var/def (core-symbol "primPlusInt")) x y)) + +(define (**- x y) + (**app (**var/def (core-symbol "-")) x y)) + +(define (**1+ x) + (**+ x (**int 1))) + +;; Lists + +(define (**cons x y) + (**app (**con/def (core-symbol ":")) x y)) + +(define (**null) + (**con/def (core-symbol "Nil"))) + +(define (**list . args) + (**list/l args)) + +(define (**list/l args) + (if (null? args) + (**null) + (**cons (car args) + (**list/l (cdr args))))) + +(define (**list/pattern pats) + (if (null? pats) + (**pcon/def (core-symbol "Nil") '()) + (**pcon/def (core-symbol ":") + (list (car pats) (**list/pattern (cdr pats)))))) + +(define (**append . lists) + (**append/l lists)) + +(define (**append/l lists) + (if (null? (cdr lists)) + (car lists) + (**app (**var/def (core-symbol "++")) + (car lists) + (**append/l (cdr lists))))) + +(define (**take n l) + (**app (**var/def (core-symbol "take")) n l)) + +(define (**drop n l) + (**app (**var/def (core-symbol "drop")) n l)) + +;; Functionals + +(define (**dot fn . args) + (**dot/l fn args)) + +(define (**dot/l fn args) + (if (null? args) + fn + (**app (**var/def (core-symbol ".")) fn (**dot/l (car args) (cdr args))))) + +;; Printing + +(define (**showChar x) + (**app (**var/def (core-symbol "showChar")) x)) + +(define (**space) + (**showChar (**char #\ ))) + +(define (**comma) + (**showChar (**char #\,))) + +(define (**showsPrec x y) + (**app (**var/def (core-symbol "showsPrec")) x y)) + +(define (**shows x) + (**app (**var/def (core-symbol "shows")) x)) + +(define (**showString x) + (**app (**var/def (core-symbol "showString")) x)) + +(define (**showParen x y) + (**app (**var/def (core-symbol "showParen")) x y)) + +;; Reading + +(define (**readsPrec x y) + (**app (**var/def (core-symbol "readsPrec")) x y)) + +(define (**lex x) + (**app (**var/def (core-symbol "lex")) x)) + +(define (**readParen bool fn r) + (**app (**var/def (core-symbol "readParen")) bool fn r)) + +(define (**reads s) + (**app (**var/def (core-symbol "reads")) s)) + +;;; Binary + +(define (**showBinInt i b) + (**app (**var/def (core-symbol "primShowBinInt")) i b)) + +(define (**readBinSmallInt max b) + (**app (**var/def (core-symbol "primReadBinSmallInt")) max b)) + +(define (**showBin x b) + (**app (**var/def (core-symbol "showBin")) x b)) + +(define (**readBin b) + (**app (**var/def (core-symbol "readBin")) b)) + +;;; Some higher level code generators + +;;; foldr (expanded inline) + +(define (**foldr build-fn terms init) + (if (null? terms) + init + (funcall build-fn (car terms) (**foldr build-fn (cdr terms) init)))) + +;;; Unlike foldr, this uses two sets of args to avoid tupling + +(define (**foldr2 build-fn terms1 terms2 init-fn) + (if (null? (cdr terms1)) + (funcall init-fn (car terms1) (car terms2)) + (funcall build-fn (car terms1) (car terms2) + (**foldr2 build-fn (cdr terms1) (cdr terms2) init-fn)))) + +;;; Enum + +(define (**enumFrom x) + (**app (**var/def (core-symbol "enumFrom")) x)) + +(define (**enumFromThen from then) + (**app (**var/def (core-symbol "enumFromThen")) from then)) + +(define (**enumFromTo from to) + (**app (**var/def (core-symbol "enumFromTo")) from to)) + +(define (**enumFromThenTo from then to) + (**app (**var/def (core-symbol "enumFromThenTo")) from then to)) + +;;; Cast overrides the type system + +(define (**cast x) + (make cast (exp x))) + +;;; Case. This also generates the alts. All variants of case generate +;;; an arm for each constructor in a datatype. This arm can be selected +;;; by pattern matching a value of the type, with all fields bound to vars, +;;; or with numbered or named selections. + +;;; The fn always generates the arms given the constructor. In the /con case, +;;; the fn also gets the variable list of values bound in the fields. + +(define (**case/con alg exp fn) + (**case exp + (map (lambda (con) + (let* ((arity (con-arity con)) + (vars (temp-vars "x" arity))) + (**alt/simple (**pat (cons con vars)) + (funcall fn con vars)))) + (algdata-constrs alg)))) + +;;; Selectors are integers (used for Bin) + +(define (**case/int alg exp fn) + (**case exp + (map (lambda (con) + (**alt/simple + (**pat (con-tag con)) + (funcall fn con))) + (algdata-constrs alg)))) + +;;; Selectors are strings (Text) + +(define (**case/strings alg exp fn) + (**case exp + (map (lambda (con) + (**alt/simple + (**pat (remove-con-prefix (symbol->string (def-name con)))) + (funcall fn con))) + (algdata-constrs alg)))) + +;;; Definitions containing multi-body + +(define (**multi-define fname alg nullary-fn single-fn + combine-fn else-val) + (**define/multiple fname + (append + (map (lambda (con) (**define/2 con nullary-fn single-fn combine-fn)) + (algdata-constrs alg)) + (if (not (eq? else-val '#f)) + `(((_ _) ,(funcall else-val))) + '())))) + +(define (**define/2 con nullary-fn single-fn combine-fn) + (let* ((arity (con-arity con)) + (vars1 (temp-vars "l" arity)) + (vars2 (temp-vars "r" arity))) + `(((,con ,@vars1) (,con ,@vars2)) + ,(if (eqv? arity 0) + (funcall nullary-fn) + (**foldr2 combine-fn (suspend-vars vars1) (suspend-vars vars2) + single-fn))))) + +(define (**define/multiple fn args) + (make valdef + (lhs (**pat fn)) + (definitions + (map (lambda (arg) + (make single-fun-def + (args (map (function **pat) (car arg))) + (rhs-list (list (make guarded-rhs + (guard (**omitted-guard)) + (rhs (cadr arg))))) + (where-decls '()) + (infix? '#f))) + args)))) + +(define (suspend-vars vars) (map (lambda (v) (lambda () (**var v))) vars)) + +(define (temp-vars root arity) + (temp-vars1 root 1 arity)) + +(define (temp-vars1 root i arity) + (if (> i arity) + '() + (cons (string->symbol (string-append root (number->string i))) + (temp-vars1 root (1+ i) arity)))) + +(define (tuple-con algdata) + (car (algdata-constrs algdata))) + +(define (con-string x) + (remove-con-prefix (symbol->string (def-name x)))) -- cgit v1.2.3