home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / aijournl / 1986_09 / expert2.ltg < prev    next >
Text File  |  1986-10-30  |  3KB  |  128 lines
  1.  
  2.  
  3.  
  4. Listing 2. 
  5. Lisp source code for the ATN-to-Lisp compiler.
  6.  
  7. ;;; ATN Compiler.  Copyright Jonathan Amsterdam, 1986.  All Rights
  8. ;;; Reserved.
  9.  
  10. ;;; These two functions are the meat of the compiler.  See the text for
  11. ;;; details.
  12.  
  13. (DEFMACRO DEFNODE (NAME &REST ARCS)
  14.   `(DEFUN ,NAME (WORD-LIST REG-ALIST)
  15.      (LET ((*WORD* (CAR WORD-LIST)))
  16.        (OR
  17.      ,@(MAPCAR #'COMPILE-ARC ARCS)))))
  18.  
  19. (DEFUN COMPILE-ARC (ARC)
  20.   (LET ((NAME (ARC-NAME ARC))
  21.     (TEST (ARC-TEST ARC))
  22.     (DESTINATION (ARC-DESTINATION ARC))
  23.     (ACTIONS (ARC-ACTIONS ARC)))
  24.     (CASE (ARC-TYPE ARC)
  25.       (WRD
  26.        (LET ((WORDS (IF (LISTP NAME) NAME (LIST NAME))))
  27.      `(LET ((NEW-REG-ALIST REG-ALIST))
  28.         (COND ((AND (MEMBER *WORD* ',WORDS) ,TEST)
  29.            ,@ACTIONS
  30.            (,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST))))))
  31.       (CAT
  32.        `(LET ((NEW-REG-ALIST REG-ALIST))
  33.           (COND ((AND (EQ (GET *WORD* 'CAT) ',NAME) ,TEST)
  34.              ,@ACTIONS
  35.              (,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST)))))
  36.       (TEST
  37.        `(LET ((NEW-REG-ALIST REG-ALIST))
  38.       (COND (,TEST
  39.          ,@ACTIONS
  40.          (,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST)))))
  41.       (PUSH
  42.        `(LET ((RESULT (,NAME WORD-LIST NIL)))
  43.       (LET ((*VALUE* (RESULT-VALUE RESULT))
  44.         (NEW-REG-ALIST REG-ALIST))
  45.         (COND ((AND *VALUE* ,TEST)
  46.            ,@ACTIONS
  47.            (,DESTINATION (RESULT-WORD-LIST RESULT) NEW-REG-ALIST))))))
  48.       (POP
  49.        `(LET ((NEW-REG-ALIST REG-ALIST))
  50.       (COND (,TEST
  51.            (CONS ,NAME WORD-LIST)))))
  52.       (JUMP
  53.        `(LET ((NEW-REG-ALIST REG-ALIST))
  54.       (COND (,TEST
  55.          ,@ACTIONS
  56.          (,DESTINATION WORD-LIST NEW-REG-ALIST))))))))
  57.  
  58.  
  59.  
  60. ;;; Actions on registers.
  61.  
  62. (DEFMACRO SETR (REG-NAME VALUE)
  63.   `(SETQ NEW-REG-ALIST (CONS (CONS ',REG-NAME ,VALUE) NEW-REG-ALIST)))
  64.  
  65. (DEFMACRO GETR (REG-NAME)
  66.   `(CDR (ASSOC ',REG-NAME NEW-REG-ALIST)))
  67.  
  68. ;;; This macro is useful for putting properties on symbols.
  69.  
  70. (DEFMACRO WORD (NAME &REST FEATURES)
  71.   (WORD-FEATURES NAME FEATURES))
  72.  
  73. (DEFUN WORD-FEATURES (NAME FEATURES)
  74.   (DOLIST (FEATURE FEATURES)
  75.     (PUTPROP NAME (CADR FEATURE) (CAR FEATURE))))
  76.  
  77.  
  78. ;;; The remaining definitions are support functions for the compiler.
  79.  
  80. (DEFUN ARC-TYPE (ARC)
  81.   (FIRST ARC))
  82.  
  83. (DEFUN ARC-NAME (ARC)
  84.   (SECOND ARC))
  85.  
  86. (DEFUN ARC-TEST (ARC)
  87.   (IF (EQ (ARC-TYPE ARC) 'TEST)
  88.       (SECOND ARC)
  89.       (THIRD ARC)))
  90.  
  91. (DEFUN ARC-DESTINATION (ARC)
  92.   (COND
  93.     ((EQ (ARC-TYPE ARC) 'JUMP)
  94.      (SECOND ARC))
  95.     ((EQ (ARC-TYPE ARC) 'TEST)
  96.      (THIRD ARC))
  97.     (T
  98.      (FOURTH ARC))))
  99.  
  100. (DEFUN ARC-ACTIONS (ARC)
  101.   (IF (MEMBER (ARC-TYPE ARC) '(JUMP TEST))
  102.       (CDDDR ARC)
  103.       (CDDDDR ARC)))
  104.  
  105. (DEFUN RESULT-VALUE (RESULT)
  106.   (CAR RESULT))
  107.  
  108. (DEFUN RESULT-WORD-LIST (RESULT)
  109.   (CDR RESULT))
  110.  
  111.  
  112. <*>End of file<*>
  113.  
  114.  
  115. Time remaining =  69 min.
  116. ==========================        FILE MENU       ==========================
  117.  
  118.   D)ownload a file    H)elp              L)ist files         N)ew files
  119.   U)pload a file      ?) Xfer info
  120.  
  121. More (Y),N,NS? n
  122.  
  123. File Function <D,G,H,L,N,Q,U,?>? g
  124.  
  125. It is now  4:38 PM.
  126. You have been on for 3 Min. and 5 Sec.
  127. Thanks for calling, SUSAN!
  128. Z