home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e051 / 3.ddi / COMMON / MAB.L < prev    next >
Encoding:
Text File  |  1985-01-07  |  3.8 KB  |  107 lines
  1. ng format| z)))
  2.         (setq atm (car z))
  3.         (setq val (caddr z))
  4.         (setq z (cdddr z))
  5.         (cond ((not (numberp val))
  6.                (%warn '|can bind only to numbers| val))
  7.               ((or (not (symbolp atm)) (variablep atm))
  8.                (%warn '|can bind only constant atoms| atm))
  9.               ((and (setq old (literal-binding-of atm)) (not (equal old val)))
  10.                (%warn '|attempt to rebind attribute| atm))
  11.               (t (putprop atm val 'ops-bind)))
  12.         (go top))) 
  13.  
  14. (defun literalize fexpr (l)
  15.   (prog (class-name atts)
  16.     (setq class-name (car l))
  17.     (cond ((have-compiled-production)
  18.            (%warn '|literalize called after p| class-name)
  19.            (return nil))
  20.           ((get class-name 'att-list)
  21.            (%warn '|attempt to redefine class| class-name)
  22.        (return nil)))
  23.     (setq *class-list* (cons class-name *class-list*))
  24.     (setq atts (remove-duplicates (cdr l)))
  25.     (test-attribute-names atts)
  26.     (mark-conflicts atts atts)
  27.     (putprop class-name atts 'att-list))) 
  28.  
  29. (defun vector-attribute fexpr (l)
  30.   (cond ((have-compiled-production)
  31.          (%warn '|vector-attribute called after p| l))
  32.         (t 
  33.          (test-attribute-names l)
  34.      (mapc (function vector-attribute2) l)))) 
  35.  
  36. (defun vector-attribute2 (att) (putprop att t 'vector-attribute))
  37.  
  38. (defun is-vector-attribute (att) (get att 'vector-attribute))
  39.  
  40. (defun test-attribute-names (l)
  41.   (mapc (function test-attribute-names2) l)) 
  42.  
  43. (defun test-attribute-names2 (atm)
  44.   (cond ((or (not (symbolp atm)) (variablep atm))
  45.          (%warn '|can bind only constant atoms| atm)))) 
  46.  
  47. (defun finish-literalize nil
  48.   (cond ((not (null *class-list*))
  49.          (mapc (function note-user-assigns) *class-list*)
  50.          (mapc (function assign-scalars) *class-list*)
  51.          (mapc (function assign-vectors) *class-list*)
  52.          (mapc (function put-ppdat) *class-list*)
  53.          (mapc (function erase-literal-info) *class-list*)
  54.          (setq *class-list* nil)
  55.          (setq *buckets* nil)))) 
  56.  
  57. (defun have-compiled-production nil (not (zerop *pcount*))) 
  58.  
  59. (defun put-ppdat (class)
  60.   (prog (al att ppdat)
  61.         (setq ppdat nil)
  62.         (setq al (get class 'att-list))
  63.    top  (cond ((not (atom al))
  64.                (setq att (car al))
  65.                (setq al (cdr al))
  66.                (setq ppdat
  67.                      (cons (cons (literal-binding-of att) att)
  68.                            ppdat))
  69.                (go top)))
  70.         (putprop class ppdat 'ppdat))) 
  71.  
  72. ; note-user-assigns and note-user-vector-assigns are needed only when
  73. ; literal and literalize are both used in a program.  They make sure that
  74. ; the assignments that are made explicitly with literal do not cause problems
  75. ; for the literalized classes.
  76.  
  77. (defun note-user-assigns (class)
  78.   (mapc (function note-user-assigns2) (get class 'att-list)))
  79.  
  80. (defun note-user-assigns2 (att)
  81.   (prog (num conf buck clash)
  82.         (setq num (literal-binding-of att))
  83.     (and (null num) (return nil))
  84.     (setq conf (get att 'conflicts))
  85.     (setq buck (store-binding att num))
  86.     (setq clash (find-common-atom buck conf))
  87.     (and clash
  88.          (%warn '|attributes in a class assigned the same number|
  89.                 (cons att clash)))
  90.         (return nil)))
  91.  
  92. (defun note-user-vector-assigns (att given needed)
  93.   (and (> needed given)
  94.        (%warn '|vector attribute assigned too small a value in literal| att)))
  95.  
  96. (defun assign-scalars (class)
  97.   (mapc (function assign-scalars2) (get class 'att-list))) 
  98.  
  99. (defun assign-scalars2 (att)
  100.   (prog (tlist num bucket conf)
  101.         (and (literal-binding-of att) (return nil))
  102.         (and (is-vector-attribute att) (return nil))
  103.         (setq tlist (buckets))
  104.         (setq conf (get att 'conflicts))
  105.    top  (cond ((atom tlist)
  106.                (%warn '|could not generate a binding| att)
  107.                (store-binding