Cleanup pt. inf+

scmvm/language/scheme.scm

@@ -4,11 +4,8 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:use-module ((rnrs base)
-                #:version (6)
-                #:select (assert))
+  #:use-module (d- oop)
   #:export (desugar-prgm
             cps-convert-prgm
             ir-convert))
@@ -300,63 +297,6 @@
     (newline))
   (ir-interpreter))
 
- ;; Optimization
-(define-syntax-rule (define-cps-type name field ...)
-  (begin
-    (define-cps-record-type name field ...)
-    (set-record-type-printer! name cps-printer)))
-
-(define-syntax define-cps-record-type
-  (lambda (ctx)
-    (define (syntax-append id . syns)
-      (datum->syntax id (apply symbol-append (map syntax->datum syns))))
-    (syntax-case ctx ()
-      [(_ name field ...)
-       (with-syntax ([ctor (syntax-append #'name #'make- #'name)]
-                     [pred (syntax-append #'name #'name #'?)]
-                     [(getter ...) (map (lambda (f) (syntax-append f #'name #'- f))
-                                        #'(field ...))])
-         #'(define-record-type name
-             (ctor field ...)
-             pred
-             (field getter) ...))])))
-
-(define (cps-printer cps port)
-  (format port "<cps ~s>" (unparse-cps cps)))
-
-(define-cps-type $constant val)
-(define-cps-type $primitive name)
-(define-cps-type $var name)
-(define-cps-type $abstraction vars body ktail)
-(define-cps-type $alternative pred kt kf)
-(define-cps-type $fix vars exps body)
-(define-cps-type $assignment var exp cont)
-(define-cps-type $application f args ktail)
-
-(define (parse-cps exp)
-  (match exp
-    [(? constant?) (make-$constant exp)]
-    [('cps-prim name) (make-$primitive name)]
-    [(? symbol?) (make-$var exp)]
-    [('lambda (vars ... ktail) body) (make-$abstraction (map parse-cps vars) (parse-cps body) ktail)]
-    [('if pred k1 k2) (make-$alternative (parse-cps pred) k1 k2)]
-    [('letrec ([vars exps] ...) body) (make-$fix (map parse-cps vars) (map parse-cps exps) (parse-cps body))]
-    [('set!-then var exp cont) (make-$assignment var (parse-cps exp) (parse-cps cont))]
-    [(f args ... ktail) (make-$application (parse-cps f) (map parse-cps args) ktail)]
-    [_ (error "unexpected cps while parsing" exp)]))
-
-(define (unparse-cps exp)
-  (match exp
-    [($ $constant val) val]
-    [($ $primitive name) `(cps-prim ,name)]
-    [($ $var name) name]
-    [($ $abstraction vars body ktail) `(lambda (,@(map unparse-cps vars) ,ktail) ,(unparse-cps body))]
-    [($ $alternative pred kt kf) `(if ,(unparse-cps pred) ,kt ,kf)]
-    [($ $fix vars exps body) `(letrec ,(zip (map unparse-cps vars) (map unparse-cps exps)) ,(unparse-cps body))]
-    [($ $assignment var expr cont) `(set!-then ,(unparse-cps var) ,(unparse-cps expr) ,(unparse-cps cont))]
-    [($ $application fun args ktail) `(,(unparse-cps fun) ,@(map unparse-cps args) ,ktail)]
-    [_ (error "Unexpected cps while unparsing" exp)]))
-
  ;; Compilation
 
 (define (meaning e r)