Move internal/library to internal, xerox font dirs, loadup and medleydir (#709)

* Move internal/library to internal, xerox font dirs, loadup and medleydir

* and MEDLEYDIR too

* mised some changes in 'promote/internal'

* tiny typo

internal/TYPEHAX

@@ -0,0 +1,70 @@
+
(FILECREATED "30-Sep-86 18:49:53" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;4
 3701   
+
+      changes to:  (VARS TYPEHAXCOMS)
+                   (FUNCTIONS COLLECT-SUPER-CHAIN TEST-TYPEP ALLOCATE-WITH-NAME ALLOCATE-SUPER-CHAIN 
+                          ALLOCATE-11-BIT-TYPES ALLOCATE-TO-TYPE-NUMBER)
+
+      previous date: "30-Sep-86 15:05:33" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;1)
+
+
+(PRETTYCOMPRINT TYPEHAXCOMS)
+
+(RPAQQ TYPEHAXCOMS
 ((FUNCTIONS ALLOCATE-11-BIT-TYPES ALLOCATE-SUPER-CHAIN ALLOCATE-TO-TYPE-NUMBER 
+                           ALLOCATE-WITH-NAME COLLECT-SUPER-CHAIN TEST-TYPEP)))
+(DEFUN ALLOCATE-11-BIT-TYPES
 NIL (ALLOCATE-TO-TYPENUMBER 1023)

+                                                  (* ;;; 
+
      "allocates typenumber 1023, then allocates a type named %"realbig%", and checks it's instances")

+                                 (ALLOCATE-WITH-NAME (QUOTE REALBIG))
+                                 (CL:SETQ AREALBIG (NCREATE (QUOTE REALBIG)))
+                                 (TYPENAMEP AREALBIG (QUOTE REALBIG))
+                                 (EQ (NTYPX AREALBIG)
+                                     1024))
+
+(DEFUN ALLOCATE-SUPER-CHAIN
 (DEPTH &OPTIONAL (SUPER* (QUOTE SUPER*-TYPE))
+                                   (ROOT (QUOTE ROOT-TYPE))) 

+                                                  (* ;;; 
+
                                                  "Allocates datatypes up to datatype x inclusive.")

+   (LET ((SUPER (CAAR (DECLAREDATATYPE SUPER* (QUOTE (POINTER))
+                             NIL NIL NIL))))
+        (DOTIMES (I (- DEPTH 1))
+               (SETQ SUPER (CAAR (DECLAREDATATYPE (GENSYM (QUOTE TEST))
+                                        (QUOTE (POINTER))
+                                        NIL NIL SUPER))))
+        (DECLAREDATATYPE ROOT (QUOTE (POINTER))
+               NIL NIL SUPER)))
+
+(DEFUN ALLOCATE-TO-TYPE-NUMBER
 (X) 
               (* ;;; 
+
                                                  "Allocates datatypes up to datatype x inclusive.")

+   (LET ((REMAINING (- X \MaxTypeNumber)))
+        (CL:IF (< REMAINING 1)
+               (CL:ERROR "There are already ~D datatypes." \MaxTypeNumber)
+               (PROGN (DECLAREDATATYPE (QUOTE TEST-SUPER)
+                             (QUOTE (POINTER))
+                             NIL NIL)
             (* ;; "declare a super for the rest of the types.")

+                      (DOTIMES (I REMAINING)
+                             (DECLAREDATATYPE (GENSYM (QUOTE TEST))
+                                    (QUOTE (POINTER))
+                                    NIL NIL (QUOTE TEST-SUPER)))))))
+
+(DEFUN ALLOCATE-WITH-NAME
 (TYPENAME &OPTIONAL (SUPER (QUOTE TEST-SUPER)))
+   (ETYPECASE TYPENAME (SYMBOL (DECLAREDATATYPE TYPENAME (QUOTE (POINTER))
+                                      NIL NIL SUPER))))
+
+(DEFUN COLLECT-SUPER-CHAIN
 (ROOT) (CL:DO* ((TYPE ROOT SUPER)
+                                           (SUPER (GETSUPERTYPE TYPE)
+                                                  (GETSUPERTYPE TYPE))
+                                           (SUPER-CHAIN NIL))
+                                         ((NULL SUPER)
+                                          SUPER-CHAIN)
+                                         (CL:PUSH SUPER SUPER-CHAIN)))
+
+(DEFUN TEST-TYPEP
 (TYPE) 
                         (* ;;; 
+
                                "ensures that instances of TYPE are instances of all its supertypes.")

+   (LET ((INSTANCE (NCREATE TYPE)))
+        (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPE)
+                                       (TYPEP INSTANCE TYPE)))
+               (COLLECT-SUPER-CHAIN TYPE))))
+
+(DECLARE: DONTCOPY
+  (FILEMAP (NIL)))
+STOP