home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e051 / 3.ddi / COMMON / OPSENV.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  8.5 KB  |  266 lines
  1. ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷                   INSTALLING OPS5 UNDER FRANZ
  2. ----------------------------------------------------------------------
  3.  
  4. The following files are needed to install OPS5 under FRANZ.
  5.     VPS2.L    -- FRANZ sources for the interpreter.
  6.     TRY5.L    -- One-rule system to check whether the
  7.              interpreter has been installed properly.
  8.  
  9. To install  OPS5 on a  VAX running  franz lisp, first  compile vps2.l
  10. with the  lisp compiler.   Then  run lisp and  give it  the following
  11. commands:
  12.  
  13.     (fasl 'vps2.o)
  14.     (i-g-v)
  15.  
  16. At that  point OPS5 is  ready to  use.  The  core image can  be saved
  17. using dumplisp or savelisp.
  18.  
  19. To  check the  interpreter,  run OPS5  and  load TRY5.L.    If it  is
  20. working, the interpreter will print the message:
  21.     ops5 installed
  22.  
  23. The file MAB.L  contains a small example OPS5 production  system.  It
  24. solves a version of  the old Monkey and Bananas problem.   To run it,
  25. load it in and give the commands:
  26.     (make start 1)
  27.     (run)
  28.  
  29. atus satified))
  30.  
  31.  
  32.  
  33. (p mb5
  34.     (goal ^status active ^type;    VPS2 -- Interpreter for OPS5
  35. ;
  36. ;    Copyright (C) 1979, 1980, 1981
  37. ;    Charles L. Forgy,  Pittsburgh, Pennsylvania
  38.  
  39.  
  40.  
  41. ; Users of this interpreter are requested to contact
  42. ;
  43. ;    Charles Forgy
  44. ;    Computer Science Department
  45. ;    Carnegie-Mellon University
  46. ;    Pittsburgh, PA  15213
  47. ; or
  48. ;    Forgy@CMUA
  49. ; 
  50. ; so that they can be added to the mailing list for OPS5.  The mailing list
  51. ; is needed when new versions of the interpreter or manual are released.
  52.  
  53.  
  54. ;;; Definitions
  55.  
  56.  
  57.  
  58. (declare (special *matrix* *feature-count* *pcount* *vars* *cur-vars*
  59.           *curcond* *subnum* *last-node* *last-branch* *first-node*
  60.           *sendtocall* *flag-part* *alpha-flag-part* *data-part*
  61.           *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
  62.           *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
  63.           *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
  64.           *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
  65.           *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
  66.           *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
  67.           *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
  68.           *c60* *c61* *c62* *c63* *c64* *record-array* *result-array* 
  69.           *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
  70.           *conflict-set* *halt-flag* *phase* *critical*
  71.           *cycle-count* *total-token* *max-token* *refracts* 
  72.           *limit-token* *total-wm* *current-wm* *max-wm*
  73.           *action-count* *wmpart-list* *wm* *data-matched* *p-name*
  74.           *variable-memory* *ce-variable-memory* *max-index*
  75.           *next-index* *size-result-array* *rest* *build-trace* *last*
  76.           *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* 
  77.           *write-file* *record-index* *max-record-index* *old-wm*
  78.           *record* *filters* *break-flag* *strategy* *remaining-cycles*
  79.       *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* 
  80.       *ce-count* *brkpts* *class-list* *buckets* *action-type*))
  81.  
  82. (declare (localf ce-gelm gelm peek-sublex sublex
  83.           eval-nodelist sendto and-left and-right not-left not-right
  84.           top-levels-eq add-token real-add-token remove-old
  85.           remove-old-num remove-old-no-num removecs insertcs dsort
  86.           best-of best-of* conflict-set-compare =alg ))
  87.  
  88.  
  89. ;;; Functions that were revised so that they would compile efficiently
  90.  
  91.  
  92. ;* The function == is machine dependent!
  93. ;* This function compares small integers for equality.  It uses EQ
  94. ;* so that it will be fast, and it will consequently not work on all
  95. ;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
  96.  
  97. (def == (macro (z) `(eq ,(cadr z) ,(caddr z))))
  98.  
  99. ; =ALG returns T if A and B are algebraicly equal.
  100.  
  101. (defun =alg (a b) (zerop (difference a b)))
  102.  
  103. (def fast-symeval 
  104.   (macro (z)
  105.      `(cond ((eq ,(cadr z) '*c1*) *c1*)
  106.         ((eq ,(cadr z) '*c2*) *c2*)
  107.         ((eq ,(cadr z) '*c3*) *c3*)
  108.         ((eq ,(cadr z) '*c4*) *c4*)
  109.         ((eq ,(cadr z) '*c5*) *c5*)
  110.         ((eq ,(cadr z) '*c6*) *c6*)
  111.         ((eq ,(cadr z) '*c7*) *c7*)
  112.         (t (eval ,(cadr z)))]
  113.  
  114. ; getvector and putvector are fast routines for using one-dimensional
  115. ; arrays.  these routines do no checking; they assume
  116. ;    1. the array is a vector with 0 being the index of the first
  117. ;       element
  118. ;    2. the vector holds arbitrary list values
  119.  
  120. ; Example call: (putvector array index value)
  121.  
  122. (def putvector
  123.   (macro (z)
  124.     (list '*rplacx (caddr z) (cadr z) (cadddr z))]
  125.  
  126. ; Example call: (getvector name index)
  127.  
  128. (def getvector
  129.   (macro (z)
  130.     (list 'cxr (caddr z) (cadr z))]
  131.  
  132. (defun ce-gelm (x k)
  133.   (prog nil
  134.    loop (and (== k 1.) (return (car x)))
  135.         (setq k (1- k))
  136.         (setq x (cdr x))
  137.         (go loop))) 
  138.  
  139. ; The loops in gelm were unwound so that fewer calls on DIFFERENCE
  140. ; would be needed
  141.  
  142. (defun gelm (x k)
  143.   (prog (ce sub)
  144.         (setq ce (/ k 10000.))
  145.         (setq sub (- k (* ce 10000.)))
  146.    celoop (and (== ce 0.) (go ph2))
  147.         (setq x (cdr x))
  148.         (and (== ce 1.) (go ph2))
  149.         (setq x (cdr x))
  150.         (and (== ce 2.) (go ph2))
  151.         (setq x (cdr x))
  152.         (and (== ce 3.) (go ph2))
  153.         (setq x (cdr x))
  154.         (and (== ce 4.) (go ph2))
  155.         (setq ce (- ce 4.))
  156.         (go celoop)
  157.    ph2  (setq x (car x))
  158.    subloop (and (== sub 0.) (go finis))
  159.         (setq x (cdr x))
  160.         (and (== sub 1.) (go finis))
  161.         (setq x (cdr x))
  162.         (and (== sub 2.) (go finis))
  163.         (setq x (cdr x))
  164.         (and (== sub 3.) (go finis))
  165.         (setq x (cdr x))
  166.         (and (== sub 4.) (go finis))
  167.         (setq x (cdr x))
  168.         (and (== sub 5.) (go finis))
  169.         (setq x (cdr x))
  170.         (and (== sub 6.) (go finis))
  171.         (setq x (cdr x))
  172.         (and (== sub 7.) (go finis))
  173.         (setq x (cdr x))
  174.         (and (== sub 8.) (go finis))
  175.         (setq sub (- sub 8.))
  176.         (go subloop)
  177.    finis (return (car x)))) 
  178.  
  179.  
  180. ;;; Utility functions
  181.  
  182.  
  183. (def neq (macro (a) `(not (eq ,(cadr a) ,(caddr a]
  184.  
  185.  
  186. (defun printline (x) (mapc (function printline*) x)) 
  187.  
  188. (defun printline* (y) (princ '| |) (print y)) 
  189.  
  190. (defun printlinec (x) (mapc (function printlinec*) x)) 
  191.  
  192. (defun printlinec* (y) (princ '| |) (princ y)) 
  193.  
  194. ; intersect two lists using eq for the equality test
  195.  
  196. (defun interq (x y)
  197.   (cond ((atom x) nil)
  198.         ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
  199.         (t (interq (cdr x) y)))) 
  200.  
  201. (defun i-g-v nil
  202.  (prog (x)
  203.     (sstatus translink t)
  204.     (setsyntax '\{ 66.)
  205.     (setsyntax '\} 66.)
  206.     (setsyntax '^ 66.)
  207.     (setq *buckets* 64.)        ; OPS5 allows 64 named slots
  208.     (setq *accept-file* nil)
  209.     (setq *write-file* nil)
  210.     (setq *trace-file* nil)
  211.     (setq *class-list* nil)
  212.     (setq *brkpts* nil)
  213.     (setq *strategy* 'lex)
  214.       (setq *in-rhs* nil)
  215.       (setq *ptrace* t)
  216.       (setq *wtrace* nil)
  217.       (setq *recording* nil)
  218.         (setq *refracts* nil)
  219.     (setq *real-cnt* (setq *virtual-cnt* 0.))
  220.     (setq *max-cs* (setq *total-cs* 0.))
  221.       (setq *limit-token* 1000000.)
  222.     (setq *limit-cs* 1000000.)
  223.     (setq *critical* nil)
  224.     (setq *build-trace* nil)
  225.     (setq *wmpart-list* nil)
  226.     (setq *size-result-array* 127.)
  227.     (setq *result-array* (*makhunk 6))
  228.     (setq *record-array* (*makhunk 6))
  229.     (setq x 0)
  230.   loop    (putvector *result-array* x nil)
  231.     (setq x (1+ x))
  232.     (and (not (> x *size-result-array*)) (go loop))
  233.     (make-bottom-node)
  234.     (setq *pcount* 0.)
  235.     (initialize-record)
  236.     (setq *cycle-count* (setq *action-count* 0.))
  237.     (setq *total-token*
  238.            (setq *max-token* (setq *current-token* 0.)))
  239.     (setq *total-cs* (setq *max-cs* 0.))
  240.     (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
  241.     (setq *conflict-set* nil)
  242.     (setq *wmpart-list* nil)
  243.     (setq *p-name* nil)
  244.     (setq *remaining-cycles* 1000000)]
  245.  
  246. ; if the size of result-array changes, change the line in i-g-v which
  247. ; sets the value of *size-result-array*
  248.  
  249. (defun %warn (what where)
  250.   (prog nil
  251.     (terpri)
  252.     (princ '?)
  253.     (and *p-name* (princ *p-name*))
  254.     (princ '|..|)
  255.     (princ where)
  256.     (princ '|..|)
  257.     (princ what)
  258.     (return where))) 
  259.  
  260. (defun %error (what where)
  261.     (%warn what where)
  262.     (throw '!error! !error!)) 
  263.  
  264. (defun round (x) (fix (plus 0.5 x))) 
  265.  
  266. (d