;;;   VSAID 	-*-MODE:LISP;PACKAGE:SI-*- 		  -*-LISP-*-
;;;   **************************************************************
;;;   *** MACLISP ******* Aid to MACLISP for VECTORs ***************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

;;; See second page for commentary

(eval-when (eval compile)
	   (or (status nofeature MACLISP) 
	       (status macro /#)
	       (setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO)) 
	   (and (status feature MACLISP)
		(status nofeature MULTICS)
		(sstatus feature PDP10))
	   )

(eval-when (eval compile)
	   (and (status nofeature MACAID)  (load '((LISP) MACAID)))
)
#Q (globalize "PTR-TYPEP" "PAIRP" "LISTP" "SEQUENCEP" "MAKE-LIST" 
	      "TYPECASEQ" "MAKE-VECTOR" "VECTOR" "VECTORP" "VREF" 
	      "VSET" "VECTOR-LENGTH" "REPLACE" "SUBSEQ" "ELT" 
	      "SETELT" "SYMBOLCONC" "NIL-INTERN" 
	      )

(herald VSAID /57)

(eval-when (load)
	   (and #-LISPM 
		(status feature COMPLR)
		(special |+internal-VECTOR-class-object/|| 
			 |+internal-EXTEND-class-object/||
			 |+internal-CLASS-class-object/|| ))
)

(eval-when (compile)
	   (and (status nofeature VSAID) (load '((LISP) VSAID)))
)

(declare (/@define defsimplemac defbothmacro))



;;; VECTOR primitive support routines which help NILAID and DEFVST
;;; A sequence of length "n" is translated into a hunk of size "n+2"
;;;   where the 1st element is the symbolic data type. (0th for CLASSes).
;;;   On LISPM, they translate into ART-Qs of 1 dimension.
;;; Primitive data-type support:
;;; 	PTR-TYPEP, PAIRP, LISTP, SEQUENCEP, MAKE-LIST, TYPECASEQ (as a macro)
;;; VECTOR  support macros:
;;; 	MAKE-VECTOR, VECTOR, VECTORP, VREF, VSET, VECTOR-LENGTH, 
;;; Misc support functions:
;;;	REPLACE, SUBSEQ, ELT, SETELT, SYMBOLCONC, 
;;; Also, all the MACAID file is loaded in, for some macro-expansion support:
;;; 	DEFSIMPLEMAC, DEFBOTHMACRO, |constant-p/||, |no-funp/||, 
;;; 	|carcdrp/|| |side-effectsp/|| 


;;; Here's some particular macro definitions and declaractions,
;;;  knowing that the intended target is with the other maclisp 
;;;  NILCOM software.
#M (declare (*LEXPR STRING-REPLACE STRING-SUBSEQ STRING-MISMATCHQ 
	      SYMBOLCONC )
	    (*EXPR PTR-TYPEP MAKE-STRING STRING-PNGET 
		   CHAR CHAR-N RPLACHAR RPLACHAR-N STRING-LENGTH)
	    (FIXNUM (CHAR-N () FIXNUM))
	    (NOTYPE (RPLACHAR-N () FIXNUM FIXNUM)))


#M  (defun |index+2-examine/|| (H N)
	 (cond ((|constant-p/|| N)
		(cond ((fixp N) (+ 2 N))
		      ((and (not (atom N)) (eq (car N) 'QUOTE) (fixp (cadr N)))
		       (+ 2 (cadr N)))
		      ('t `(+ 2 ,n))))
	       ((OR (|constant-p/|| H) 
		    (AND (NOT (|side-effectsp/|| N)) 
			 (NOT (|side-effectsp/|| H))))
		`(+ 2 ,n))))


;;; What a gross shaft ensues if you try to uses the MACROEXPANDED
;;;    memoizing feature with this macro, **SELF-EVAL**!

#M (macro **SELF-EVAL** (x) `(QUOTE ,x))



(comment initial CLASS stuff)

  ; This is merely an internal helper function
#+PDP10
 (progn 'compile 
  (declare (setq defmacro-check-args () ))
  (defmacro *:EXTEND (class &rest data)
  	`(HUNK '**SELF-EVAL** ,@data ,class))
  (defcomplrmac |cons-a-NEWdtp| (type &rest data)
     (or (memq type '(STRING CLASS VECTOR CHARACTER BITS)) 
	 (error '|what the heck? - cons-a-NEWdtp| type))
     (cond ((eq type 'CLASS)
	    (setq data `(,(car data) () () () () ()))))
     `(*:EXTEND ,(intern (symbolconc '|+internal-| type '|-class-object/||)) 
	       ,.data))
  (defmacro *:CLASS-OF (ob) `(CDR ,ob))
  (defun CLASS-OF (ob)   ;; Called by SENDI.  Must be fast.
     (declare (special *:PRIMITIVE-TYPES-CLASS-TABLE))
     (cond ((hunkp ob) (*:class-of ob))
	   ('t (error '|CLASS-OF doesn't work on non-EXTENDs!| ob 'fail-act))))
  (defmacro *:CLASS-TYPEP (class) `(CXR 2 ,class))
  (defmacro *:CLASS-SUPRS (class) `(CXR 3 ,class))
  (defmacro *:CLASS-SENDI (class) `(CXR 4 ,class))
  (defmacro *:CLASS-CALLI (class) `(CXR 5 ,class))
  (defmacro *:CLASS-METHODS (class) `(CXR 6 ,class))
  (defmacro *:CLASS-DESCR (class) `(CXR 7 ,class))
   ;CLASSES have 6 significant components [the car and cdr are respectively
   ;  forced to be **SELF-EVAL** and the super-class marker]
  (defcomplrmac *:CLASSP (item &aux (y (gensym)))
	`(LET ((,y ,item))
	    (COND ((OR (NOT (HUNKP ,y))
		       (NOT (EQ (CAR ,y) '**SELF-EVAL**))
		       (< (VECTOR-LENGTH ,y) 6))
		   () )
		  ((OR (EQ (SETQ ,y (*:CLASS-OF ,y)) 
			   |+internal-CLASS-class-object/||)
		       (EQ ,y '|CLASS-of-CLASSES: The BUCK stops here!/||))
		   'T)
		    ;The following several lines constitute an open-coding of 
		    ; (EQUAL (cddr item) |+internal-CLASS-class-object/||)
		  ((OR (NOT (HUNKP ,y))
		       (NOT (EQ (CAR ,y) '**SELF-EVAL**))
		       (< (VECTOR-LENGTH ,y) 6))
		   () )
		  ((AND (EQ (*:CLASS-TYPEP ,y) 'CLASS)
			(EQ (*:CLASS-OF ,y) 
			    '|CLASS-of-CLASSES: The BUCK stops here!/||))
		   'T))))
  )
;;; ########## MULTICS NEWdtp ?
#-PDP10
  (progn 'compile 
      #+MULTICS
        (progn 'compile 
	   (defcomplrmac AR-1 (&rest w) `(ARRAYCALL T ,.w))
	   (defcomplrmac AS-1 (val &rest w) `(STORE (ARRAYCALL T ,.w) ,val))
	)
      (defmacro |cons-a-NEWdtp| (type &rest data)
	(or (memq type '(STRING CLASS VECTOR CHARACTER BITS)) 
	    (error '|what the heck? - cons-a-NEWdtp| type))
	`(|Fill-NEWdtp| ,(intern (string-append "+internal-" 
						(string type) 
						"-class-object/|"))
			,. data))
      (defun |Fill-NEWdtp| (type &rest data)
	 (do ((h (make-array () 'ART-Q (1+ (length data))))
	      (i 1 (1+ i)))
	     ((null x)
	      (as-1 type h 0)
	      h)
	   (as-1 (car x) h i)))
   )

 ; Here comes the original bootstrap for the CLASS system!
(SETQ |+internal-CLASS-class-object/|| () 
      |+internal-CLASS-class-object/|| (|cons-a-NEWdtp| CLASS 'CLASS))

#+PDP10  (rplacx 0 
		 |+internal-CLASS-class-object/|| 
		 '|CLASS-of-CLASSES: The BUCK stops here!/||)

#-PDP10  (as-1 '|CLASS-of-CLASSES: The BUCK stops here!/|| 
	       |+internal-CLASS-class-object/||
	       0)

(SETQ |+internal-VECTOR-class-object/|| (|cons-a-NEWdtp| CLASS 'VECTOR))



(comment PTR-TYPEP and type macros)

(defun PTR-TYPEP (x) 
    (cond ((null x) 'CONSTANT)
#+PDP10	  ((hunkp x) 
	   (cond ((and (eq (car x) '**SELF-EVAL**) 
		       (*:classp (*:class-of x)))
		  (or (car (memq (*:class-typep (*:class-of x))
				 '(STRING CHARACTER VECTOR BITS
					  CONSTANT SUBR SMALL-FLONUM)))
		      'EXTEND))
		 ((and (eq (car x) '**SELF-EVAL**) 
		       (eq (cdr x) '|CLASS-of-CLASSES: The BUCK stops here!/||))
		  'EXTEND)
		 ('t 'HUNK)))
	  ((let ((typ (typep x)))
		(cond ((eq typ 'LIST) 'PAIR)
#Q		      ((and (eq typ 'ARRAY)
			    (eq (array-type x) 'ART-Q)
			    (= (array-/#-dims x) 1))
		       (setq typ (ar-1 x 0))
		       (cond ((and (arrayp typ)
				   (eq (array-type typ) 'ART-Q)
				   (= (array-/#-dims typ) 1)
				   (cond ((eq (ar-1 typ 0) |+internal-CLASS-class-object/||))
					 ((eq (ar-1 typ 0) '|CLASS-of-CLASSES: The BUCK stops here!/||))
					  ;The following is an open-coding of 
					  ; (EQUAL (ar-1 typ 0)  |+internal-CLASS-class-object/||)
					 ((and (arrayp (ar-1 typ 0))
					       (eq (array-tyep (ar-1 typ 0)) 'ART-Q)
					       (= (array-/#-dims (ar-1 typ 0)) 1)
					       (eq (ar-1 (ar-1 typ 0) 0) 
						   '|CLASS-of-CLASSES: The BUCK stops here!/||)
					       (eq (ar-1 (ar-1 typ 0) 1) 'CLASS)))))
			      (ar-1 typ 1))
			     ('ARRAY)))
	#+MULTICS     ((eq typ 'ARRAY) (error '|not yet coded - PTR-TYPEP|))
		      ((eq typ 'BIGNUM) 'EXTEND)
		      ('t typ))))))


(defmacro TYPECASEQ (x &rest y) `(CASEQ (PTR-TYPEP ,x) ,@y))

(defbothmacro PAIRP (x) `(EQ (TYPEP ,x) 'LIST))
(defbothmacro VECTORP (x) `(EQ (PTR-TYPEP ,x) 'VECTOR))

(defbothmacro LISTP simple (x) 
   `(OR (NULL ,x)
	(EQ (TYPEP ,x) 'LIST)))
(defbothmacro SEQUENCEP simple (x)
   `(OR (NULL ,x) 
	(AND (MEMQ (PTR-TYPEP ,x) 
		   '(PAIR STRING VECTOR VECTOR-S EXTEND BITS)) 'T)))

(comment VECTOR primitives)

#+PDP10
  (progn 'compile 
      (defbothmacro VECTOR-LENGTH (x) `(- (HUNKSIZE ,x) 2))
      (defbothmacro VREF (h n)
	(let ((tmp (|index+2-examine/|| h n)) htem)
	     (cond (tmp `(CXR ,tmp ,h))
		   ('T (setq htem (gensym) tmp (gensym))
			 `((LAMBDA (,htem ,tmp) 
				   (CXR (+ 2 ,tmp) ,htem))
			   ,h ,n)))))
      (defbothmacro VSET (h n val)
	(let ((tmp (|index+2-examine/|| h n)) htem)
	     (cond (tmp `(RPLACX ,tmp ,h ,val))
		   ('T (setq htem (gensym) tmp (gensym))
			 `((LAMBDA (,htem ,tmp) 
				   (RPLACX (+ 2 ,tmp) ,htem ,val))
			   ,h ,n)))))
      (defbothmacro *:MAKE-EXTEND (n cl)
	(let ((v (gensym)))
	     `(LET ((,v (MAKHUNK (+ ,n 2))))
		   (RPLACX 0 ,v ,cl)
		   (RPLACX 1 ,v '**SELF-EVAL** ))))
)	;end of #M


#-PDP10 
  (progn 'compile 
      (defbothmacro VECTOR-LENGTH (x) `(- (ARRAY-DIMENSION-N 1 ,x) 1))
      (defbothmacro VREF (h n) `(AR-1 ,h (1+ ,n)))
      (defbothmacro VSET (h n val)
	 (cond ((or (|side-effectsp/|| h) 
		    (|side-effectsp/|| n) 
		    (|side-effectsp/|| val))
		(let ((htem (gensym)) (tmp (gensym)))
		     `((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem (1+ ,tmp))) 
		       ,h ,n)))
	       (`(AS-1 ,val ,h (1+ ,n)))))
      (defbothmacro *:MAKE-EXTEND (n cl) 
	(let ((v (gensym)))
	     `(LET ((,v (MAKE-ARRAY () 'ART-Q (1+ ,n))))
		   (AS-1 ,cl ,v 0)
		   ,v)))
)	;end of #Q 


(defbothmacro MAKE-VECTOR (n)
    `(*:MAKE-EXTEND ,n |+internal-VECTOR-class-object/||))

(defun VECTOR #M n #Q (&rest x &aux (n (length x)))
   (declare (fixnum n))
   (cond ((= n 0) () )
	 ('t  (do ((v (make-vector n))
	   #Q      (l x (cdr l))
		   (i 0 (1+ i)))
		  ((not (< i n)) v)
		 (vset v i #M (arg (1+ i)) #Q (car l))))))


(comment  MAKE-LIST  ELT  SYMBOLCONC)


(defun MAKE-LIST (count)
     (do ((l () (cons () l)) (n count (1- n)))
	 ((< n 1) l)
       (declare (fixnum n))))


(DEFUN ELT (V I)
   (DECLARE (FIXNUM I))
   (TYPECASEQ V
	(PAIR (NTH I V))
	(VECTOR (VREF V I))
	(STRING (CHAR V I))
	(BITS (BIT V I))
	(T (ELT (ERROR V '|Sequence is required - ELT| 'WRNG-TYPE-ARG) I))))

(DEFUN SETELT (V I X)
   (DECLARE (FIXNUM I))
   (TYPECASEQ V
	(PAIR (RPLACA (NTHCDR I V) X))
	(VECTOR (VSET V I X))
	(STRING (RPLACHAR V I X))
	(BITS (RPLACBIT V I X))
	(T (SETELT (ERROR V '|Sequence is required - SETELT| 'WRNG-TYPE-ARG)
		   I 
		   X))))


(DEFUN SYMBOLCONC N
   (DECLARE (FIXNUM I J LN N))
   (DO ((I 1 (1+ I)) (LN 0) (ANS) (TYP) (A))
       ((> I N) (IMPLODE (NREVERSE ANS)))
     (COND ((COND ((EQ (SETQ TYP (TYPEP (SETQ A (ARG I)))) 'SYMBOL)
		   (SETQ A (EXPLODEN A))
		   'T)
		  ((EQ TYP 'LIST) (SETQ A (APPEND A () )) 'T))
	    (SETQ ANS (NRECONC A ANS)))
	   ((HUNKP A)
	    (COND ((COND ((EQ (SETQ TYP (PTR-TYPEP A)) 'STRING)
			  (SETQ LN (STRING-LENGTH A))
			  'T)
			 ((MEMQ TYP '(VECTOR VECTOR-S))
			  (SETQ LN (VECTOR-LENGTH A))
			  'T))
		   (DO ((J 0 (1+ J)))
		       ((NOT (< J LN)))
		     (PUSH (COND ((EQ TYP 'VECTOR) (VREF A J))
				 ('T (CHAR-N A J)))
			   ANS)))
		  ('T (ERROR '|BAD ARG - SYMBOLCONC| A)))))))



#M (progn 'compile 
      (DEFPROP STRING-PNGET ((LISP) STRING FASL) AUTOLOAD)
      (mapc '(lambda (x) (putprop x '((LISP) SUBSEQ FASL) 'AUTOLOAD))
	    '(REPLACE SUBSEQ TO-LIST TO-VECTOR))
    )

(SSTATUS FEATURE VSAID)