home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cfn / main.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.3 KB  |  61 lines  |  [TEXT/CCL2]
  1. t.  It is called by the driver on
  2. ;;; each top-level decl in the module.
  3.  
  4. (define (cfn-ast x)
  5.   (let ((result  (cfn-ast-1 x)))
  6. ;    (pprint result)  ;*** debug
  7.     result))
  8.  
  9.  
  10.  
  11. ;;;===================================================================
  12. ;;; Default traversal methods
  13. ;;;===================================================================
  14.  
  15.  
  16. (define-local-syntax (make-cfn-code slot type)
  17.   (let ((stype  (sd-type slot))
  18.         (sname  (sd-name slot)))
  19.     (cond ((and (symbol? stype)
  20.                 (or (eq? stype 'exp)
  21.                     (subtype? stype 'exp)))
  22.            `(setf (struct-slot ',type ',sname object)
  23.                   (cfn-ast-1 (struct-slot ',type ',sname object))))
  24.           ((and (pair? stype)
  25.                 (eq? (car stype) 'list)
  26.                 (symbol? (cadr stype))
  27.                 (or (eq? (cadr stype) 'exp)
  28.                     (subtype? (cadr stype) 'exp)))
  29.            `(setf (struct-slot ',type ',sname object)
  30.                   (cfn-ast/list (struct-slot ',type ',sname object))))
  31.           ((and (pair? stype)
  32.                 (eq? (car stype) 'list)
  33.                 (eq? (cadr stype) 'decl))
  34.            `(setf (struct-slot ',type ',sname object)
  35.                   (cfn-valdef-list (struct-slot ',type ',sname object))))
  36.           (else
  37. ;          (format '#t "Cfn: skipping slot ~A in ~A~%"
  38. ;                  (sd-name slot)
  39. ;                  type)
  40.            '#f))))
  41.  
  42. (define-modify-walker-methods cfn
  43.   (let if
  44.    exp-sign
  45.    app
  46.    var-ref con-ref
  47.    integer-const float-const char-const string-const
  48.    con-number sel is-constructor
  49.    void
  50.    case-block return-from and-exp
  51.    )
  52.   (object)
  53.   make-cfn-code)
  54.  
  55.  
  56. ;;; These have specialized walkers:
  57. ;;; lambda, case, valdef, list-comp  (pattern.scm)
  58. ;;; list-exp, list-comp, section-l, section-r, dict-placeholder,
  59. ;;; recursive-placeholder, save-old-exp (misc.scm)
  60.  
  61.