home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / syntax.em‾ < prev    next >
Encoding:
Text File  |  1993-07-23  |  11.2 KB  |  403 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: syntax.em
  4. ;; Date: 30/jun/1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  Transforms a piece of eulisp into an
  9. ;;  abstract syntax tree
  10. ;;
  11.  
  12. (defmodule syntax 
  13.   (standard0
  14.    list-fns
  15.    syntx-env
  16.    )
  17.   ()
  18.   
  19.   ;;
  20.   ;; Translator into abstract syntax...
  21.   ;; covers most cases now (I hope)
  22.   ;;
  23.   (defclass Syntax-Error (<condition>)
  24.     (msg values)
  25.     )
  26.  
  27.   (export Syntax-Error)
  28.   (defconstant get-import-translator (mk-finder))
  29.   (defconstant get-module-translator (mk-finder))
  30.   
  31.   ;; cop out at the moment...
  32.   (defun find-translator (syntax-env ob)
  33.     (syntax-env ob))
  34.   
  35.   (defun translate-expr (syntax-env form)
  36.     (syntax-env form))
  37.     
  38.   (defun translate (ob)
  39.     (translate-expr (std-module-translator ())
  40.             ob))
  41.  
  42.   ;; could be generic...
  43.   (defun std-module-translator (env)
  44.     (lambda (form)
  45.       (cond ((eq form t) (literal form))
  46.         ;; nil always evaluates to ()!
  47.         ((eq form 'nil) (literal nil))
  48.         ((symbolp form) (ident form))
  49.         ((atom form) (literal form))
  50.         (t;; otherwize...
  51.          (let ((tran (get-module-translator-1 (car form))))
  52.            (if tran 
  53.            (tran (std-module-translator env) (cdr form))
  54.          (let ((macro (find-macro env (car form))))
  55.            (if macro 
  56.                (progn (format t  "Macro: ~a~%" (car form))
  57.                   (translate-expr (std-module-translator env)
  58.                           (compile-macro-expand (expander (cdr macro))
  59.                                     (cdr form))))
  60.              (translate-applic (std-module-translator env) form)))))))))
  61.   
  62.   (defun get-module-translator-1 (exp)
  63.     (cond ((atom exp)
  64.        (get-module-translator exp))
  65.       ((eq (car exp) 'lambda)
  66.        (rewrite-inline-lambda (cdr exp)))
  67.       (t nil)))
  68.  
  69.   ;; really only nasty 'cos someone may do ((lambda x ...) 1 2 3 4)
  70.   (defun rewrite-inline-lambda (lambda-term)
  71.     (labels ((rewrite-args (args values)
  72.                (cond ((null args) nil)
  73.                  ((atom args) 
  74.                   (list (list args (cons 'list values))))
  75.                  (t (cons (list (car args) (car values))
  76.                       (rewrite-args (cdr args) (cdr values)))))))
  77.       (lambda (tran args)
  78.     (translate-expr tran
  79.             (print `(let ,(rewrite-args (car lambda-term) args)
  80.                   ,@(cdr lambda-term)))))))
  81.  
  82.  
  83.   (defun import-translator (form)
  84.     ((get-import-translator (car form)) import-translator (cdr form)))
  85.  
  86.   (defun translate-applic (syntax-env form)
  87.     (make-applic (translate-expr syntax-env (car form))
  88.          (mapcar (lambda (form) (translate-expr syntax-env form))
  89.              (cdr form))))
  90.   
  91.   ((setter get-module-translator) 'progn
  92.    (lambda (syntax-env txt)
  93.      (make-sequence
  94.       (mapcar (lambda (ob)
  95.         (translate-expr syntax-env ob))
  96.           (if (null txt) (list nil) txt)))))
  97.  
  98.   (defun end-mapcar (fn lst)
  99.     (if (consp lst)
  100.     (cons (fn (car lst)) (end-mapcar fn (cdr lst)))
  101.       (if lst (fn lst) ())))
  102.  
  103.   ((setter get-module-translator) 'lambda 
  104.    (lambda (syntax-env txt)
  105.      (make-lambda (end-mapcar make-lambda-id (car txt))
  106.           (translate-expr syntax-env 
  107.                   (cons 'progn (cdr txt)))
  108.           )))
  109.   
  110.   ((setter get-module-translator) '%extended-lambda
  111.    (lambda (syntax-env txt)
  112.      (make-extended-lambda (car txt) (cadr txt)
  113.                (end-mapcar make-lambda-id (caddr txt))
  114.                (translate-expr syntax-env
  115.                        (cons 'progn 
  116.                          (cdddr txt)))
  117.                )))
  118.  
  119.   ((setter get-module-translator) 'let 
  120.    (lambda (syntax-env txt)
  121.      (make-block (make-and-decl
  122.           (mapcar (lambda (decl)
  123.                 (make-definition (car decl)
  124.                          (translate-expr syntax-env (cadr decl))
  125.                          t))
  126.               (car txt)))
  127.          (translate-expr syntax-env 
  128.                  (cons 'progn (cdr txt))))))
  129.  
  130.  
  131.   ;; the real labels...
  132.   ((setter get-module-translator) 'labels
  133.    (lambda (syntax-env txt)
  134.      (make-block 
  135.       (make-rec-decl
  136.        (make-and-decl
  137.     (mapcar (lambda (decl)
  138.           (make-definition (car decl)
  139.                    (translate-expr syntax-env (cons 'lambda (cdr decl)))
  140.                    nil))
  141.         (car txt))))
  142.       (translate-expr syntax-env 
  143.               (cons 'progn (cdr txt))) )))
  144.               
  145.   ((setter get-module-translator) 'if
  146.    (lambda (syntax-env txt)
  147.      (if (or (null txt) 
  148.          (null (cdr txt))
  149.          (null (cddr txt)))
  150.      (progn (cerror "Syntax in if statement" Syntax-Error
  151.             'msg "**Invalid if expression: ~a~%"
  152.             'values (cons 'if txt))
  153.         (make-error-term))
  154.        (make-cond (translate-expr syntax-env (car txt))
  155.           (translate-expr syntax-env (cadr txt))
  156.           (translate-expr syntax-env (caddr txt))))))
  157.   
  158.  
  159.   ((setter get-module-translator) 'defun 
  160.    (lambda (syntax-env txt)
  161.      (make-block (make-rec-decl (make-module-definition 
  162.                  (car txt) 
  163.                  (let ((doc-text (defun-code txt)))
  164.                    (translate-expr syntax-env
  165.                            `(%extended-lambda ,(car txt) ,(car doc-text) ,@(cdr doc-text))))
  166.                  nil))
  167.          (translate-expr syntax-env (car txt)))))
  168.   
  169.   (defun defun-code (txt)
  170.     (if (and (stringp (caddr txt))
  171.          (not (null (cdddr txt))))
  172.     (cons (caddr txt)
  173.           (cons (cadr txt) 
  174.             (cdddr txt)))
  175.       (cons "" (cdr txt))))
  176.  
  177.   ;; A long shot, but it might just work...
  178.   ((setter get-module-translator) 'defmacro
  179.    (lambda (syntax-env txt)
  180.      (make-block (make-rec-decl (make-module-definition 
  181.                  (car txt) 
  182.                  (make-macro-lambda (end-mapcar make-lambda-id (cadr txt))
  183.                             (translate-expr syntax-env
  184.                                     (cons 'progn (cddr txt))))
  185.                  nil))
  186.          (translate-expr syntax-env (car txt)))))
  187.  
  188.   ;; defconstant + deflocal return their values...
  189.   ((setter get-module-translator) 'defconstant
  190.    (lambda (syntax-env txt)
  191.      (make-block
  192.       (make-module-definition 
  193.        (car txt) 
  194.        (translate-expr syntax-env (if (cdr txt) (cadr txt) nil))
  195.        nil)
  196.       (translate-expr syntax-env (car txt)))))
  197.  
  198.   ((setter get-module-translator) 'deflocal
  199.    (lambda (syntax-env txt)
  200.      (make-block
  201.       (make-module-definition 
  202.        (car txt) 
  203.        (translate-expr 
  204.     syntax-env 
  205.     (if (cdr txt) (cadr txt) nil))
  206.        t)
  207.       (translate-expr syntax-env (car txt)))))
  208.  
  209.   ((setter get-module-translator) 'call-next-method
  210.    (lambda (syntax-env txt)
  211.      (mk-call-next-method-term)))
  212.     
  213.   ((setter get-module-translator) '%Compiler-special
  214.    (lambda (syntax-env txt)
  215.      (mk-special-term  (car txt) (cdr txt))))
  216.   
  217.   ((setter get-module-translator) '%Compiler-special-object
  218.    (lambda (syntx-env txt)
  219.      (mk-special-term2 (car txt) (cadr txt) (mapcar (lambda (exp)
  220.                               (translate-expr syntx-env exp))
  221.                             (cddr txt)))))
  222.   ;; wronginsh
  223.   ((setter get-module-translator) 'export
  224.    (lambda (syntax-env txt)
  225.      (make-export-directive 
  226.       txt)))
  227.  
  228.   ((setter get-module-translator) 'expose
  229.    (lambda (syntax-env txt)
  230.      (make-expose-directive 
  231.       (translate-expr import-translator 
  232.               (hack-imports txt)))))
  233.  
  234.   ((setter get-module-translator) 'setq
  235.    (lambda (syntax-env txt)
  236.      (assignment (translate-expr syntax-env (car txt))
  237.          (translate-expr syntax-env (cadr txt)))))
  238.  
  239.   ((setter get-module-translator) 'quote
  240.    (lambda (syntax-env txt)
  241.      (literal (car txt))))
  242.   
  243.   
  244.   (defun find-imports (lst)
  245.     (let ((new (scan-args 'import lst null-argument)))
  246.       (or new lst)))
  247.  
  248.   ((setter get-module-translator) 'defmodule
  249.    (lambda (syntax-env txt)
  250.      (let* ((import-expr (translate-expr import-translator
  251.                      (hack-imports (find-imports (cadr txt)))))
  252.         (new-env (make-local-syntax syntax-env import-expr)))
  253.        (make-module (car txt)
  254.             import-expr
  255.             nil ;; syntax
  256.             nil ;; exports
  257.             (make-sequence (mapcar (lambda (x) 
  258.                          (translate-expr (cdr new-env) x))
  259.                        (cdddr txt)))
  260.             'import-list (car new-env)))))
  261.   
  262.   ;; syntax depends heavily on imports :-(  )
  263.   (defun make-local-syntax (mod-env imports)
  264.     (let ((i (read-imports imports)))
  265.       (cons i (std-module-translator i))))
  266.   
  267.   ;; judiciously add a few imports...
  268.   (defun hack-imports (import-spec)
  269.     (cons 'union
  270.       (mapcar (lambda (x) 
  271.             (cond ((symbolp x) (list 'import x))
  272.               (t x)))
  273.           import-spec)))
  274.  
  275.   ((setter get-import-translator) 'import 
  276.    (lambda (syntax-env txt)
  277.      (make-import-directive (car txt))))
  278.  
  279.   ((setter get-import-translator) 'rename
  280.    (lambda (syntax-env txt)
  281.      (make-rename-directive (car txt)
  282.                 (translate-expr syntax-env (hack-imports (cdr txt))))))
  283.   ((setter get-import-translator) 'except
  284.    (lambda (syntax-env txt)
  285.      (make-except-directive (car txt)
  286.                 (translate-expr syntax-env (hack-imports (cdr txt))))))
  287.  
  288.   ((setter get-import-translator) 'only
  289.    (lambda (syntax-env txt)
  290.      (make-only-directive (car txt)
  291.               (translate-expr syntax-env (hack-imports (cdr txt))))))
  292.  
  293.   ((setter get-import-translator) 'union
  294.    (lambda (syntax-env txt)
  295.      (make-union-directive 
  296.       (mapcar (lambda (x) 
  297.         (translate-expr syntax-env x))
  298.           txt))))
  299.   ;;
  300.   ;; printing the beastie
  301.   ;;
  302.  
  303.   (defmethod print-term ((tm syntax-obj) stream)
  304.     (format stream "#<term: ~a>" (class-name (class-of stream))))
  305.  
  306.   (defmethod print-term ((tm ident-term) stream)
  307.     (prin (term-id tm) stream))
  308.  
  309.   (defmethod print-term ((tm literal-term) stream)
  310.     (write (literal-content tm) stream))
  311.  
  312.   (defmethod print-term ((tm special-term) stream)
  313.     (format stream "(%special:~a ~a)" 
  314.         (special-term-name tm)
  315.         (special-term-data tm)))
  316.  
  317.   (defmethod print-term ((cond condition-term) stream)
  318.     (prin "(if " stream)
  319.     (print-term (cond-test cond) stream)
  320.     (prin " " stream)
  321.     (print-term (cond-t-part cond) stream)
  322.     (prin " " stream)
  323.     (print-term (cond-f-part cond) stream)
  324.     (prin ")" stream))
  325.  
  326.   (defmethod print-term ((l-term lambda-term) stream)
  327.     (prin "(lambda " stream)
  328.     (prin (lambda-ids l-term) stream)
  329.     (print-term (lambda-body l-term) stream)
  330.     (prin ")" stream))
  331.  
  332.   (defmethod print-term ((applic applic-term) stream)
  333.     (prin "(" stream)
  334.     (print-term (applic-fun applic) stream)
  335.     (mapcar (lambda (term)
  336.           (prin " " stream)
  337.           (print-term term stream))
  338.         (applic-args applic))
  339.     (prin ")" stream))
  340.  
  341.   (defmethod print-term ((seq sequence) stream)
  342.     (prin "(progn" stream)
  343.     (mapcar (lambda (term)
  344.           (prin " " stream)
  345.           (print-term term stream))
  346.         (sequence-content seq))
  347.     (prin ")" stream))
  348.  
  349.   (defmethod print-term ((assign assignment-term) stream)
  350.     (prin "(setq " stream)
  351.     (prin (assign-var assign) stream)
  352.     (print-term (assign-body assign) stream)
  353.     (prin ")" stream))
  354.  
  355.   (defmethod print-term ((blck block-term) stream)
  356.     (prin "(let (" stream)
  357.     (print-decl (block-decl blck) stream)
  358.     (prin ") " stream)
  359.     (print-term (block-body blck) stream)
  360.     (prin ")" stream))
  361.  
  362.   (defmethod print-term ((blck call-next-method-term) stream)
  363.     ;;(format stream "(call-next-method)")
  364.     (call-next-method))
  365.  
  366.   (defmethod print-term ((exp export-directive) stream)
  367.     (prin "(exp: " stream)
  368.     (print (export-spec-name exp))
  369.     (prin ")"))
  370.  
  371.   (defmethod print-decl ((decl and-decl) stream)
  372.     (mapcar (lambda (x) (print-decl x stream))
  373.         (and-decl-decls decl)))
  374.  
  375.   (defmethod print-decl ((decl rec-decl) stream)
  376.     (prin "rec (" stream)
  377.     (print-decl (rec-decl-decl decl) stream)
  378.     (prin ")" stream))
  379.  
  380.  (defmethod generic-prin ((x term) stream)
  381.     (prin "#<Term: " stream)
  382.     (print-term x stream)
  383.     (prin ">"))
  384.  
  385.   (defmethod generic-prin ((x decl) stream)
  386.     (prin "#<decl:" stream)
  387.     (print-decl x stream)
  388.     (prin ">"))
  389.   (export translate get-module-translator)
  390.  
  391.   ;; Test function
  392.  
  393.   (defun test () 
  394.     (let* ((file (open "test.em"))
  395.        (forms (read file)))
  396.       (close file)
  397.       (translate forms)))
  398.   (export test)
  399.  
  400.  
  401.   ;; end module
  402.   )
  403.