(FILECREATED "18-Jan-79 19:55:53" <LISPUSERS>CIALPHORDER..1 5055   


     changes to:  CIALPHORDERCOMS

     previous date: "18-Jan-79 19:54:41" <LISPUSERS>CIALPHORDER..1)


(PRETTYCOMPRINT CIALPHORDERCOMS)

(RPAQQ CIALPHORDERCOMS ((FNS CIALPHORDER)))
(DEFINEQ

(CIALPHORDER
  [LAMBDA (A B)                              (* Edited by M.Yonke on 
					     12-Jan-79.)

    (* * Compares two atoms and returns T if they are in order.
    Order precedence is numbers, literals, and everything else.
    Numbers are sorted by magnitude. Literals 
    (strings, atoms, and pnames) are sorted alphabetically 
    (but case independent). Other types come at the end.)


    (PROG ((TB (NTYP B)))
          (SELECTQ (NTYP A)
		   (20 (ASSEMBLE NIL         (* A is SMALLP)
			         (CQ A)
			         (SUBI 1 , ASZ))
		                             (* Fast unbox for small 
					     numbers.)
		       (GO UNBOXEDINT))
		   (18 (ASSEMBLE NIL
			         (CQ A)
			         (MOVE 1 , 0 (1))
                                             (* Fast unbox for large 
					     numbers.)
			     )
		                             (* A is integer)
		       (GO UNBOXEDINT))
		   [16                       (* A is floating)
		       (SELECTQ TB
				[16          (* Both floating.
					     Do open FGREATERP.)
				    (ASSEMBLE NIL
					      (CQ B)
					      (MOVE 2 , 0 (1))
                                             (* Fast unbox but into floating
					     format.)
					      (CQ A)
					      (CAMGE 2 , 0 (1))
					      (SKIPA 1 , KNIL)
					      (CQ T)
					      (CQ (RETURN (AC]
				(20 (ASSEMBLE NIL
					      (CQ B)
					      (SUBI 1 , ASZ)))
				[18 (ASSEMBLE NIL
					      (CQ B)
					      (MOVE 1 , 0 (1]
				(RETURN T))
		                             (* Return T for A floating, B 
					     non-numeric.)
		       (ASSEMBLE NIL
			         (FASTCALL FXFLT)
                                             (* Unboxed (integer) B in ac1.
					     FLOAT it and compare to A.)
			         (LDV2 'A SP 2)
			         (CAMGE 1 , 0 (2))
			         (SKIPA 1 , KNIL)
			         (CQ T)
			         (CQ (RETURN (AC]
		   (12 (ASSEMBLE NIL         (* A is LITATOM)
			         (CQ A)
			         (HLRZ 1 , 2 (1)))
		       (GO LIT))
		   ((24 28)
		                             (* A is string or pname)
		     (ASSEMBLE NIL
			       (CQ A))
		     (GO LIT))
		   (SELECTQ TB
			    ((28 24 12 20 18 16)
			      

    (* A is list, ARRAY or junk; B is something legal so it 
    belongs first.)


			      (RETURN NIL))
			    (RETURN T)))     (* Both junk; return T.)
      UNBOXEDINT
          [ASSEMBLE NIL                      (* Unboxed integer A in ac1.
					     Stack it.)
		    (PUSHN)
		    (CQ (SELECTQ TB
				 (24Q (ASSEMBLE NIL
					        (CQ B)
					        (SUBI 1 , ASZ)))
				 [22Q (ASSEMBLE NIL
					        (CQ B)
					        (MOVE 1 , 0 (1]
				 [20Q (ASSEMBLE NIL
					        (NREF (MOVE 1 , 0))
					        (FASTCALL FXFLT)

    (* A integral, B floating. float unboxed A on stack and load 
    ac1 with unboxed B.)


					        (NREF (MOVEM 1 , 0))
					        (CQ B)
					        (MOVE 1 , 0 (1]
				 (RETURN T)))
                                             (* A numeric, B not.)
		    (NREF (CAMGE 1 , 0))

    (* Compare two unboxed numbers. Fixed or floating doesn't 
    matter as long as both the same.)


		    (SKIPA 1 , KNIL)
		    (CQ T)
		    (POPNN 1)
		    (CQ (RETURN (AC]
      LIT (ASSEMBLE NIL
		    (FASTCALL UPATM)

    (* Ac3 has byte ptr to A; ac4 has NCHARS.
    Notice use of CP here.)


		    (PUSHN 4)
		    (PUSH CP , 3)
		    [CQ (SELECTQ TB
				 ((24Q 22Q 20Q)
				   (ASSEMBLE NIL
					     (POP CP , 1))
				             (* A was literal, B numeric.)
				   (RETURN))
				 ((30Q 34Q)
				   (ASSEMBLE NIL
					     (CQ B)))
				 [14Q (ASSEMBLE NIL
					        (CQ B)
					        (HLRZ 1 , 2 (1]
				 (ASSEMBLE NIL
				           (POP CP , 1)
                                             (* A was literal, B was list or
					     junk.)
				           (CQ (RETURN T]

    (* At last the basic alphabetizer. Ac6 has NCHARS A;
    ac5 has byte pointer to A; ac4 has NCHARS B 
    (from this call to UPATM), ac3 has byte pointer to B.)


		    (FASTCALL UPATM)
		    (POP CP , 5)
		    (POPN 6)
		LP  (SOJL 6 , SUCCEED)       (* A won because shorter)
		    (SOJL 4 , FAIL)          (* B won because shorter.)
		    (ILDB 1 , 5)
		    (CAIL 1 , 141Q)
		    (CAILE 1 , 172Q)
		    (SKIPA)
		    (SUBI 1 , 40Q)
		    (ILDB 2 , 3)
		    (CAIL 2 , 141Q)
		    (CAILE 2 , 172Q)
		    (SKIPA)
		    (SUBI 2 , 40Q)
		    (CAMN 1 , 2)
		    (JRST LP)                (* Chars the same, try again.)
		    (CAML 1 , 2)

    (* A and B have different spellings. Compare magnitude of 
    character byte and exit with result.)


		FAIL(SKIPA 1 , KNIL)
		SUCCEED
		    (CQ T)
		    (CQ (RETURN (AC])
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (264 5031 (CIALPHORDER 276 . 5028)))))
STOP