home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / ATT.P < prev    next >
Encoding:
Text File  |  1984-10-13  |  2.6 KB  |  73 lines
  1. ;;;; This file contains an ATT language-understanding program.
  2.  
  3. ;;; This section contains the procedures that set up the ATTs.
  4.  
  5. (DEFMACRO RECORD X
  6.   (LET* ((NAME (FIRST X)) (TREE (SECOND X))
  7.          (VARIABLES (GET-SUBTREE-NAMES TREE)))
  8.     `(DEFUN ,NAME (REMAINING-WORDS)
  9.        ;(PROCLAIM '(SPECIAL ,@VARIABLES)) reinstate when lexical!!
  10.        (LET ,(MAPCAR #'(LAMBDA (VARIABLE) (LIST VARIABLE NIL))
  11.                      VARIABLES)
  12.          (INTERPRET-ATT REMAINING-WORDS ',TREE)))))
  13.  
  14. (DEFUN GET-SUBTREE-NAMES (X)
  15.   (REMOVE-DUPLICATES (GET-SUBTREE-NAMES1 X)))
  16.  
  17. (DEFUN GET-SUBTREE-NAMES1 (X)
  18.   (COND ((NULL X) NIL)
  19.         ((ATOM X) NIL)
  20.         ((AND (EQUAL (CAR X) 'PARSE)        ;Detect PARSE expression.
  21.               (CDR X)
  22.               (NOT (CDDR X)))
  23.          (LIST (CADR X)))
  24.         (T (MAPCAN 'GET-SUBTREE-NAMES1 X))))
  25.  
  26. ;;; This section contains the guts of the ATT interpreter.
  27.  
  28. (DEFUN INTERPRET-ATT (REMAINING-WORDS TREE)
  29.   (COND ((NULL TREE)
  30.          (LIST T REMAINING-WORDS))
  31.         ((ATOM (CAR TREE))
  32.          (COND ((EQUAL (CAR REMAINING-WORDS) (CAR TREE))
  33.                 (INTERPRET-ATT (CDR REMAINING-WORDS) (CDR TREE)))
  34.                (T NIL)))               
  35.         ((EQUAL (INSTRUCTION-NAME TREE) 'PARSE)
  36.          (LET ((RESULT (FUNCALL (SUBTREE-NAME TREE) REMAINING-WORDS)))
  37.            (COND (RESULT
  38.                   (SET (SUBTREE-NAME TREE) (CAR RESULT))
  39.                   (INTERPRET-ATT (CADR RESULT) (CDR TREE)))
  40.                  (T NIL))))
  41.         ((EQUAL (INSTRUCTION-NAME TREE) 'BRANCH)
  42.          (INTERPRET-BRANCHES REMAINING-WORDS (CDAR TREE)))
  43.         ((EQUAL (INSTRUCTION-NAME TREE) 'PARSE-RESULT)
  44.          (LIST (CAR (LAST (MAPCAR 'EVAL (CDAR TREE))))
  45.                REMAINING-WORDS))
  46.         ((EQUAL (INSTRUCTION-NAME TREE) 'PARSE-RESULT-IF-END)
  47.          (COND ((NULL REMAINING-WORDS)
  48.                 (LIST (CAR (LAST (MAPCAR 'EVAL (CDAR TREE))))
  49.                       NIL))
  50.                (T NIL)))))
  51.  
  52. (DEFUN INTERPRET-BRANCHES (REMAINING-WORDS BRANCHES)
  53.   (COND ((NULL BRANCHES) NIL)
  54.         ((INTERPRET-ATT REMAINING-WORDS (CAR BRANCHES)))
  55.         (T (INTERPRET-BRANCHES REMAINING-WORDS (CDR BRANCHES)))))
  56.  
  57. ;;; This section contains selector procedures for getting at
  58. ;;; parts of the results returned by PARSE.
  59.  
  60. (DEFUN INSTRUCTION-NAME (TREE) (CAAR TREE))
  61.  
  62. (DEFUN SUBTREE-NAME (TREE) (CADAR TREE))
  63.  
  64. ;;; This section contains a Common LISP primitive that is not yet
  65. ;;; in GC LISP.
  66.  
  67. (DEFUN REMOVE-DUPLICATES (L)
  68.   (IF (NULL L) NIL
  69.   (IF (MEMBER (FIRST L) (REST L))
  70.       (REMOVE-DUPLICATES (REST L))
  71.       (CONS (FIRST L) (REMOVE-DUPLICATES (REST L))))))
  72.  
  73.