home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / interface-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.8 KB  |  99 lines  |  [TEXT/CCL2]
  1. ;;; This is the parser for interface files.
  2.  
  3. (define (parse-tokens/interface tokens)
  4.   (init-token-stream tokens)
  5.   (let ((interface (token-case
  6.             (|interface| (parse-interface))
  7.             (|module| (interface-required-error))
  8.             (else (crud-in-interface-error)))))
  9.     (cons interface (parse-interface-list))))
  10.  
  11. (define (interface-required-error)
  12.   (parser-error 'interface-required "Expecting `interface' keyword"))
  13.  
  14. (define (crud-in-interface-error)
  15.   (parser-error 'unexpected-interface-crud "Junk after interface"))
  16.  
  17. (define (parse-interface-list)
  18.   (token-case
  19.    (|interface|
  20.      (let ((interface (parse-interface)))
  21.        (cons interface (parse-interface-list))))
  22.    (|module| (interface-required-error))
  23.    (eof '())
  24.    (else (crud-in-interface-error))))
  25.  
  26. (define (parse-interface)
  27.   (token-case
  28.    (modid
  29.     (let ((module-name (token->symbol)))
  30.       (require-token |where|
  31.        (signal-missing-token "`where'" "interface definition"))
  32.       (let ((mod-ast (make module (name module-name)
  33.                       (type 'interface)
  34.                   (exports '()))))
  35.     (start-layout (lambda (in-layout?)
  36.                (parse-interface-decls mod-ast in-layout? 'import))))))))
  37.  
  38. (define (parse-interface-decls mod-ast in-layout? state)
  39.   (token-case
  40.     (|import| (let ((import (parse-import)))
  41.         (when (not (eq? (import-decl-mode import) 'by-name))
  42.            (phase-error 'illegal-import
  43.     "Imports in interfaces must specify specific entities"))
  44.         (if (eq? state 'import)
  45.             (push-decl-list import (module-imports mod-ast))
  46.             (signal-misplaced-import)))
  47.           (terminate-interface-topdecl mod-ast in-layout? state))
  48.     (|infix| (terminate-interface-topdecl mod-ast in-layout?
  49.                    (parse-fixity 'n mod-ast state)))
  50.     (|infixl| (terminate-interface-topdecl mod-ast in-layout?
  51.                    (parse-fixity 'l mod-ast state)))
  52.     (|infixr| (terminate-interface-topdecl mod-ast in-layout?
  53.                    (parse-fixity 'r mod-ast state)))
  54.     (|data| (let ((data-decl (parse-type-decl '#t)))
  55.           (push-decl-list data-decl (module-algdatas mod-ast)))
  56.         (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
  57.     (|type| (let ((synonym-decl (parse-synonym-decl)))
  58.          (push-decl-list synonym-decl (module-synonyms mod-ast)))
  59.         (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
  60.     (|class| (let ((class-decl (parse-class-decl)))
  61.            (check-class-default-decls class-decl)
  62.            (push-decl-list class-decl (module-classes mod-ast)))
  63.          (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
  64.     (|instance| (let ((instance-decl (parse-instance-decl '#t '#f)))
  65.           (push-decl-list instance-decl (module-instances mod-ast)))
  66.         (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
  67.     (var (let ((decl (parse-signdecl)))
  68.        (setf (module-decls mod-ast)
  69.          (decl-push decl (module-decls mod-ast))))
  70.      (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
  71.     ((begin-annotation no-advance)
  72.      (let ((annotations (parse-annotations 'interface)))
  73.        (setf (module-annotations mod-ast)
  74.          (append (module-annotations mod-ast) annotations)))
  75.      (terminate-interface-topdecl mod-ast in-layout? state))
  76.     (else
  77.      (maybe-end-interface mod-ast in-layout?))))
  78.  
  79. (define (maybe-end-interface mod-ast in-layout?)
  80.   (cond ((or (eq-token? '|interface|) (eq-token? 'eof) (eq-token? '\})
  81.          (eq-token? '$\}))
  82.      (close-layout in-layout?)
  83.      (wrapup-module mod-ast)
  84.      mod-ast)
  85.     (else
  86.      (signal-invalid-syntax "a topdecl"))))
  87.  
  88. (define (terminate-interface-topdecl mod-ast in-layout? state)
  89.   (token-case
  90.    (\; (parse-interface-decls mod-ast in-layout? state))
  91.    (else (maybe-end-interface mod-ast in-layout?))))
  92.  
  93. (define (check-class-default-decls class-decl)
  94.   (dolist (d (class-decl-decls class-decl))
  95.     (when (valdef? d)
  96.       (remember-context d
  97.        (recoverable-error 'no-defaults-in-interface
  98.          "Class defaults should not be put in interface files")))))
  99.