parmenides

0001-foo.patch

From 269835eb6655b48b36bd0b7f2d5a6ccc78d2e53b Mon Sep 17 00:00:00 2001
From: death <death@adeht.org>
Date: Fri, 28 Aug 2020 03:05:54 +0300
Subject: [PATCH] foo

---
 parmenides.lisp | 246 +++++++++++++++++++++++++++++++-----------------
 prtest.lisp     |  14 +--
 2 files changed, 165 insertions(+), 95 deletions(-)

diff --git a/parmenides.lisp b/parmenides.lisp
index 2cc7953..06eb9f9 100644
--- a/parmenides.lisp
+++ b/parmenides.lisp
@@ -34,16 +34,16 @@
 ;;;
 ;;;   21-Oct-92  Pete Shell.  Optimized write-accessor-functions and
 ;;;   		 write-facet-refs.
-;;;                          
+;;;
 ;;;   6-Dec-89	 Daniel Borrajo.  Added a freelist module.
-;;; 
+;;;
 ;;;   15-May-89  Added a special called 'oldval' to the variables which
 ;;;		 are accessible by demons.
-;;; 
+;;;
 ;;;   11-Apr-89  Fixed a bug in maybe-fplist-append which caused Parmenides
 ;;;		 to break when defining a sub-class of a class which has
 ;;;		 the propagate class facet, and a slot is being redefined.
-;;; 
+;;;
 ;;;   1-Mar-89	 Daniel Borrajo. Also for version 1.5.
 ;;;		 Added multi-lingual capability.  Virtually
 ;;;		 all output to the user is done via ml-format, ml-cerror or
@@ -116,61 +116,135 @@
 ;;;; PACKAGE STUFF, with help and coaxing from Todd Kaufmann
 ;;;;
 
-(in-package "PARMENIDES" :nicknames '("PARM" "PA") :use '("LISP"))
-
-;;; Symbols documented in the user's manual:
-;;; These names are kept in the list *PA-EXPORTS* so that FRulekit,
-;;; which is in a different package, can export PA symbols too.  That way,
-;;; when users load FRulekit, they automatically get the PA functions.
-(eval-when (load eval compile)
-  (defparameter *PA-EXPORTS* '(		;; User-accessible functions & macros
-	  Add-Cslot Add-Slot Add-To-Facet Add-To-Facet-Demons Add-To-Value
-	  Add-To-Slot Pa-Class-Of Framep Classp Slotp Facetedp Frame-Instance-P
-	  Copy-Frame Def-Frame Def-Frame* Frame Get-Cslot Add-to-Cslot Set-Cslot
-	  Get-Facet Get-Facet-Demons Get-Generic-Value Get-Immediate-Facet
-	  Get-Immediate-Slot Get-Immediate-Value Get-Slot Get-Slot-Names
-	  Get-Value Get-Value-Demons Immediate-Isas Instance-Names-Of
-	  Instances-Of Set-Instances-Of Inverse-Isas Isa-Instance Isa-P Isas
-	  Local-P Make-Frame Make-Frame0 Fast-Make-Frame0 Remove-Frame Set-Facet
-	  Set-Facet-Demons Set-Slot Set-Value Set-Value-Demons Do-Facets
-	  Isa-Or-Instance Save-Frame Pp-Frame
-	  Define-Facet-Getter Define-Facet-Setter Define-Facet-Accessors
-	  Ml-Format Ml-Error Ml-Cerror
-	  Get-Free-Frame Release-Frame
-	  With-All-Subinstances-Of With-All-Subclasses-Of
-	  Delete-Class-Instance *PA-EXPORTS*
-
-	  ;;; FRAME-related
-	  relation make-relation relation-combination-type
-	  relation-slots-inherited.value relation-has-inverses
-	  relation-inverse-name
-
-	  ;;; Demon variables:  (as per section 5)
-
-	  framename slotname facetname frame snum facetnum newval oldval
-
-	  ;;; User-settable flags:
-
-	  *READ-ONLY* !!inheritance-type !!inheritance-link *PARMENIDES-TERSE*
-
-	  )))
-
-(export *PA-EXPORTS*)
-
-;;; Functions exported to FRulekit but not documented in user's manual (not
-;;; fully supported):
-(export
- '(Symbolics-Lisp-P Kyoto-Lisp-P Cmu-Common-Lisp-P Xerox-P Lucid-Lisp-P
-		    Dec-Lisp-P Allegro-Lisp-P #-Allegro Putprop *Aref-Fn-Names*
-		    Assure-Keyword Smash Assure-Frame Assure-Current
-		    Name-To-Frame-Type Frame-Class Replace-Frame
-		    Modify-Frame Get-Atomic-Value Keywordize-Cplist
-		    Pa-Frame-Index-Plist Pa-Get-Snf-Nums Fast-copy-frame
-		    Clear-Instances Name-frame Get-frame-name
-
-		;; Used by inter:
-		    Modify-Frame-Demons Dup-Array Write-Frame
-))
+(defpackage #:parmenides
+  (:use #:cl)
+  (:shadow
+   #:class
+   #:ftype)
+  (:export
+   #:Add-Cslot
+   #:Add-Slot
+   #:Add-To-Facet
+   #:Add-To-Facet-Demons
+   #:Add-To-Value
+   #:Add-To-Slot
+   #:Pa-Class-Of
+   #:Framep
+   #:Classp
+   #:Slotp
+   #:Facetedp
+   #:Frame-Instance-P
+   #:Copy-Frame
+   #:Def-Frame
+   #:Def-Frame*
+   #:Frame
+   #:Get-Cslot
+   #:Add-to-Cslot
+   #:Set-Cslot
+   #:Get-Facet
+   #:Get-Facet-Demons
+   #:Get-Generic-Value
+   #:Get-Immediate-Facet
+   #:Get-Immediate-Slot
+   #:Get-Immediate-Value
+   #:Get-Slot
+   #:Get-Slot-Names
+   #:Get-Value
+   #:Get-Value-Demons
+   #:Immediate-Isas
+   #:Instance-Names-Of
+   #:Instances-Of
+   #:Set-Instances-Of
+   #:Inverse-Isas
+   #:Isa-Instance
+   #:Isa-P
+   #:Isas
+   #:Local-P
+   #:Make-Frame
+   #:Make-Frame0
+   #:Fast-Make-Frame0
+   #:Remove-Frame
+   #:Set-Facet
+   #:Set-Facet-Demons
+   #:Set-Slot
+   #:Set-Value
+   #:Set-Value-Demons
+   #:Do-Facets
+   #:Isa-Or-Instance
+   #:Save-Frame
+   #:Pp-Frame
+   #:Define-Facet-Getter
+   #:Define-Facet-Setter
+   #:Define-Facet-Accessors
+   #:Ml-Format
+   #:Ml-Error
+   #:Ml-Cerror
+   #:Get-Free-Frame
+   #:Release-Frame
+   #:With-All-Subinstances-Of
+   #:With-All-Subclasses-Of
+   #:Delete-Class-Instance
+   ;; FRAME-related
+   #:relation
+   #:make-relation
+   #:relation-combination-type
+   #:relation-slots-inherited.value
+   #:relation-has-inverses
+   #:relation-inverse-name
+   ;; Demon variables:  (as per section 5)
+   #:framename
+   #:slotname
+   #:facetname
+   #:frame
+   #:snum
+   #:facetnum
+   #:newval
+   #:oldval
+   ;; User-settable flags:
+   #:*READ-ONLY*
+   #:!!inheritance-type
+   #:!!inheritance-link
+   #:*PARMENIDES-TERSE*
+   ;; Functions exported to FRulekit but not documented in user's manual (not
+   ;; fully supported):
+   #:Symbolics-Lisp-P
+   #:Kyoto-Lisp-P
+   #:Cmu-Common-Lisp-P
+   #:Xerox-P
+   #:Lucid-Lisp-P
+   #:Dec-Lisp-P
+   #:Allegro-Lisp-P
+   #:Putprop
+   #:*Aref-Fn-Names*
+   #:Assure-Keyword
+   #:Smash
+   #:Assure-Frame
+   #:Assure-Current
+   #:Name-To-Frame-Type
+   #:Frame-Class
+   #:Replace-Frame
+   #:Modify-Frame
+   #:Get-Atomic-Value
+   #:Keywordize-Cplist
+   #:Pa-Frame-Index-Plist
+   #:Pa-Get-Snf-Nums
+   #:Fast-copy-frame
+   #:Clear-Instances
+   #:Name-frame
+   #:Get-frame-name
+   ;; Used by inter:
+   #:Modify-Frame-Demons
+   #:Dup-Array
+   #:Write-Frame
+   ;; Multi-lingua
+   #:*LANGUAGE*
+   #:*PA-PATHNAME*
+   #:get-message
+   #:define-language
+   #:load-messages
+   ))
+
+(in-package #:parmenides)
 
 
 ;;;; -------------------------------------------------------------------- ;;;
@@ -180,8 +254,6 @@
 ;;; This module defines the macros and variables needed to configure the
 ;;; multilingual capability of Parmenides (and FRulekit).
 
-(export '(*LANGUAGE* *PA-PATHNAME* get-message define-language load-messages))
-
 ;;;
 ;;; IMPORTANT: In order to configure your site, set the value of *LANGUAGE*
 ;;; and *PA-PATHNAME* variables.
@@ -196,7 +268,7 @@
 (defvar *LANGUAGE* "eng")
 
 ;;; The name of the directory where the Parmenides files reside.
-(defvar *PA-PATHNAME* "/afs/cs/project/cmt/parmenides/")
+(defvar *PA-PATHNAME* "/media/1984/Documents/code/Parmenides/")
 
 ;;; The hash table containing the messages
 (defparameter *MESSAGES* (make-hash-table :size 409))
@@ -214,18 +286,18 @@
 ;;; Functions to access a message and to add a message to *MESSAGES*
 (defmacro get-message (msgname)
   `(gethash ,msgname  *MESSAGES*))
-  
+
 (defun put-message (msgname message)
   (setf (gethash msgname *MESSAGES*) message))
 
 (defun define-language (language)
   (setq *LANGUAGE* language)
   (load-messages (format NIL "~Apa-messages.~A" *PA-PATHNAME* language)))
-  
+
 (defun load-parmenides (&optional (language *LANGUAGE*))
   (define-language language)
   (load (format NIL "~Aparmenides" *PA-PATHNAME*)))
-  
+
 (define-language *LANGUAGE*)
 
 
@@ -263,7 +335,7 @@
 ;;; that the user won't modify any slot values.
 (defvar *READ-ONLY* NIL)
 
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (if (not (member :phshacks *FEATURES* :test #'eq))
       (defmacro ifnotstatus (feature &rest forms)
         `(if (not (member ,feature *FEATURES* :test #'eq))
@@ -271,7 +343,7 @@
 
 ;;; Like concat but expands what it can at expansion time and otherwise wraps
 ;;; a symbol-name call to function calls.
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
  (ifnotstatus :phshacks
    (defmacro smash (&rest seqs)
      `(intern (concatenate 'string ,@(prepare-seqs seqs))))
@@ -301,7 +373,7 @@
 	(defmacro memq (a l)
 	  `(member-if #'(lambda (mumble) (eq ,a mumble)) ,l)))))
 
-(eval-when (load eval)
+(eval-when (:load-toplevel :execute)
   (ifnotstatus :phshacks  (push :phshacks *FEATURES*)))
 
 (defmacro my-maybe-nconc (elt list)
@@ -313,7 +385,7 @@
        (copy-list ,list)
        ,list))
 
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
 
 ;;; The only difference between my-pushnew and pushnew is that pushnew
 ;;; uses setf which uses setf methods.  Pushnew doesn't work inside
@@ -411,7 +483,7 @@
 
 
 ;;; The lisps that this works under...
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (defun kyoto-lisp-p ()
     (string= (lisp-implementation-type) "Kyoto Common Lisp on MV"))
 
@@ -444,7 +516,7 @@
 	(terpri)
 	(apply *FORMAT* `(,stream ,string ,@vars)))
 
-(eval-when (eval compile load)
+(eval-when (:load-toplevel :execute :compile-toplevel)
  (defvar *AREF-FN-NAMES*
   '(%aref-get-0 %aref-get-1 %aref-get-2 %aref-get-3
 		%aref-get-4 %aref-get-5 %aref-get-6 %aref-get-7
@@ -504,7 +576,7 @@
 
 ;;; (aref *AREF-FN-MAP* N) returns the function object which is the aref
 ;;; accessor for the Nth slot.
-(eval-when (eval compile load)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (defvar *AREF-FN-MAP*
     (make-array 16
 		:initial-contents *AREF-FN-NAMES*))
@@ -541,11 +613,11 @@
 ;; Access macros
 ;;
 
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
 
   (defmacro first-position (frame)
     `(aref ,frame 0))
-  
+
   (defmacro get-frame-size (frame)
     `(car (array-dimensions ,frame)))
 
@@ -553,12 +625,12 @@
 ;; Creates a frame in case there isn't one free
 ;;
 
-(defmacro create-frame (size adjustable)
-  `(make-array ,size :adjustable ,adjustable))
+  (defmacro create-frame (size adjustable)
+    `(make-array ,size :adjustable ,adjustable))
 
 
 ;;
-;; Macro that looks for a free frame. If there isn't, it creates and 
+;; Macro that looks for a free frame. If there isn't, it creates and
 ;; returns it. If there is not room for frames of that size, it first
 ;; adjust the freelist array.
 ;;
@@ -577,11 +649,11 @@
 		  (setf (first-position ,frame-name) nil)
 		  ,frame-name)
 		 (T (create-frame ,size ,adjustable)))))))
-  
+
 ;;
 ;; Macro that pushes a frame into the free list.
 ;;
-  
+
   (defmacro release-frame (frame)
     (let ((frame-name (gentemp "frame-")))
       `(let* ((,frame-name ,frame)
@@ -596,9 +668,7 @@
 		   (setf (aref free-list size) ,frame-name)
 		   (setf (first-position ,frame-name) first-free-frame)
 		   size))
-	     (ml-format t :releasing-frame)))
-))
-)
+	     (ml-format t :releasing-frame))))))
 
 
 ;;; -------------------------------------------------------------------
@@ -1322,7 +1392,7 @@
   (format stream " ~12S " sname)
   (cond ((or (eq facetp :NO) (atom (cdr index)))  ;;then the slot is facet-less
 	 (if savep
-	     (if (and classp (not (eq facetp :NO))  ;; Write it as faceted 
+	     (if (and classp (not (eq facetp :NO))  ;; Write it as faceted
 		      (consp slot))		    ;; even though it's not.
 		 (format stream "'\(:VALUE ~S\)~%" slot)
 		 (format stream "~S~%" (if classp slot (maybe-quote slot))))
@@ -1457,7 +1527,7 @@
 
 ;;; Top-level, main class-definition function.  Returns the instance of the
 ;;; frame, which is created and filled in with the default values.
-(eval-when (eval load compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
  (defmacro def-frame (name cslots &rest slots)
   (setq *THINGS-TO-EVAL* NIL)
   (keywordize-cplist cslots)
@@ -2362,7 +2432,7 @@
 		      (ordered-union
 		       all (translate-all pgetters (car parent))))))))))
 
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (defmacro get-set-type (setable)
     `(if (consp ,setable) (car ,setable) ,setable))
 
@@ -2572,7 +2642,7 @@
 		 (cond ((eq prev plist)
 			(setf orig (cddr orig))
 			(setq prev orig))
-		       (T		      
+		       (T
 			(setf (cddr prev) (cddr plist))
 			(setq plist prev)))
 		 (if (not (eq prev plist)) (setq prev (cddr prev)))))))))
@@ -2794,7 +2864,7 @@
 ;;; SLOT ACCESSOR FUNCTIONS, BOOK-KEEPING.
 ;;;; -----------------------------------------------------------------------
 
-(eval-when (load eval compile)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (defmacro getablep (sname getters)
     `(or (eq ,getters *DEFAULT*)
 	 (memq ,sname ,getters))))
@@ -2956,7 +3026,7 @@
 
 ;;; Has-inverses and inverse-name slots added 4-1-87 to support inverse
 ;;; relations.
-(eval-when (load eval)
+(eval-when (:load-toplevel :execute)
   (def-frame* 'relation ()
     '(:combination-type :FIRST
       :slots-inherited (value :*ALL*)
diff --git a/prtest.lisp b/prtest.lisp
index d4520f1..21c9e45 100644
--- a/prtest.lisp
+++ b/prtest.lisp
@@ -27,7 +27,7 @@
 (setq b1 (make-baby 'baby1 :cries '(value always)))
 ;;; User relation testing
 
-(def-frame part2 (is-a (pa:relation))
+(def-frame part2 (is-a (relation))
   :combination-type append
   :slots-inherited (value '((location first) made-from)))
 
@@ -41,7 +41,7 @@
   :made-from (value '(cherry))
   :weight 10)
 
-(def-frame part-of (:is-a pa:relation :propagate nil)
+(def-frame part-of (:is-a relation :propagate nil)
   :combination-type :FIRST
   :slots-inherited (:value '((location :first) (made-from :append)))
   :has-inverses T
@@ -64,9 +64,9 @@
 
 (defun change-my-output ()
   (format T "Entered change-my-output ok~%")
-  (set-value pa:frame :output newval))
+  (set-value frame :output newval))
 
-(def-frame sub-part-of (is-a (pa:relation))
+(def-frame sub-part-of (is-a (relation))
   :has-inverses T
   :inverse-name super-part-of)
 
@@ -127,17 +127,17 @@
 (def-frame is-part-of (:is-a (relation))
   :combination-type first
   :slots-inherited (value :*ALL*))
- 
+
 (def-frame truck ()
    :color blue
    :weight 10000
    :material steel)
- 
+
 (def-frame door (:is-part-of (truck))
   :is-part-of truck
   :width 3
   :height 2)
- 
+
 (def-frame more (:is-a door)
   :width 4)
 
-- 
2.28.0