From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 cfn/main.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)
 create mode 100644 cfn/main.scm

(limited to 'cfn/main.scm')

diff --git a/cfn/main.scm b/cfn/main.scm
new file mode 100644
index 0000000..3853b03
--- /dev/null
+++ b/cfn/main.scm
@@ -0,0 +1,83 @@
+;;; main.scm -- main entry point for CFN pass
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  27 Feb 1992
+;;;
+
+
+;;;===================================================================
+;;; Basic support
+;;;===================================================================
+
+
+;;; Define the basic walker and some helper functions.
+
+(define-walker cfn ast-td-cfn-walker)
+
+(define (cfn-ast-1 x)
+  (call-walker cfn x))
+
+(define (cfn-ast/list l)
+  (map (lambda (x) (cfn-ast-1 x)) l))
+
+
+;;; This is the main entry point.  It is called by the driver on
+;;; each top-level decl in the module.
+
+(define (cfn-ast x)
+  (let ((result  (cfn-ast-1 x)))
+;    (pprint result)  ;*** debug
+    result))
+
+
+
+;;;===================================================================
+;;; Default traversal methods
+;;;===================================================================
+
+
+(define-local-syntax (make-cfn-code slot type)
+  (let ((stype  (sd-type slot))
+        (sname  (sd-name slot)))
+    (cond ((and (symbol? stype)
+                (or (eq? stype 'exp)
+                    (subtype? stype 'exp)))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-ast-1 (struct-slot ',type ',sname object))))
+          ((and (pair? stype)
+                (eq? (car stype) 'list)
+                (symbol? (cadr stype))
+                (or (eq? (cadr stype) 'exp)
+                    (subtype? (cadr stype) 'exp)))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-ast/list (struct-slot ',type ',sname object))))
+          ((and (pair? stype)
+                (eq? (car stype) 'list)
+                (eq? (cadr stype) 'decl))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-valdef-list (struct-slot ',type ',sname object))))
+          (else
+;          (format '#t "Cfn: skipping slot ~A in ~A~%"
+;                  (sd-name slot)
+;                  type)
+           '#f))))
+
+(define-modify-walker-methods cfn
+  (let if
+   exp-sign
+   app
+   var-ref con-ref
+   integer-const float-const char-const string-const
+   con-number sel is-constructor
+   void
+   case-block return-from and-exp
+   )
+  (object)
+  make-cfn-code)
+
+
+;;; These have specialized walkers:
+;;; lambda, case, valdef, list-comp  (pattern.scm)
+;;; list-exp, list-comp, section-l, section-r, dict-placeholder,
+;;; recursive-placeholder, save-old-exp (misc.scm)
+
-- 
cgit v1.2.3