Import to github.
[software/yale-haskell.git] / cfn / main.scm
1 ;;; main.scm -- main entry point for CFN pass
2 ;;;
3 ;;; author : Sandra Loosemore
4 ;;; date : 27 Feb 1992
5 ;;;
6
7
8 ;;;===================================================================
9 ;;; Basic support
10 ;;;===================================================================
11
12
13 ;;; Define the basic walker and some helper functions.
14
15 (define-walker cfn ast-td-cfn-walker)
16
17 (define (cfn-ast-1 x)
18 (call-walker cfn x))
19
20 (define (cfn-ast/list l)
21 (map (lambda (x) (cfn-ast-1 x)) l))
22
23
24 ;;; This is the main entry point. It is called by the driver on
25 ;;; each top-level decl in the module.
26
27 (define (cfn-ast x)
28 (let ((result (cfn-ast-1 x)))
29 ; (pprint result) ;*** debug
30 result))
31
32
33
34 ;;;===================================================================
35 ;;; Default traversal methods
36 ;;;===================================================================
37
38
39 (define-local-syntax (make-cfn-code slot type)
40 (let ((stype (sd-type slot))
41 (sname (sd-name slot)))
42 (cond ((and (symbol? stype)
43 (or (eq? stype 'exp)
44 (subtype? stype 'exp)))
45 `(setf (struct-slot ',type ',sname object)
46 (cfn-ast-1 (struct-slot ',type ',sname object))))
47 ((and (pair? stype)
48 (eq? (car stype) 'list)
49 (symbol? (cadr stype))
50 (or (eq? (cadr stype) 'exp)
51 (subtype? (cadr stype) 'exp)))
52 `(setf (struct-slot ',type ',sname object)
53 (cfn-ast/list (struct-slot ',type ',sname object))))
54 ((and (pair? stype)
55 (eq? (car stype) 'list)
56 (eq? (cadr stype) 'decl))
57 `(setf (struct-slot ',type ',sname object)
58 (cfn-valdef-list (struct-slot ',type ',sname object))))
59 (else
60 ; (format '#t "Cfn: skipping slot ~A in ~A~%"
61 ; (sd-name slot)
62 ; type)
63 '#f))))
64
65 (define-modify-walker-methods cfn
66 (let if
67 exp-sign
68 app
69 var-ref con-ref
70 integer-const float-const char-const string-const
71 con-number sel is-constructor
72 void
73 case-block return-from and-exp
74 )
75 (object)
76 make-cfn-code)
77
78
79 ;;; These have specialized walkers:
80 ;;; lambda, case, valdef, list-comp (pattern.scm)
81 ;;; list-exp, list-comp, section-l, section-r, dict-placeholder,
82 ;;; recursive-placeholder, save-old-exp (misc.scm)
83