(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
                     T)
         (LISPXPRIN1 (QUOTE " 8-JAN-73 23:34:50")
                     T)
         (LISPXTERPRI T))
(DEFINEQ

(STRPOSL
  [LAMBDA (L STR START NEG)
    (PROG NIL                                   (* E (RADIX 10Q))
                                                (* Initialize bit table 
                                                (on number stack) and 
                                                set up pointer.)
          (ASSEMBLE NIL
                    (CQ NEG)
                    (CAMN 1 , ' NIL)
                    (SKIPA 2 , = 0)
                    (MOVNI 2 , 1)
                    (PUSH NP , 2)
                    (PUSH NP , 2)
                    (PUSH NP , 2)
                    (PUSH NP , 2)
                    (SKIPA 1 , INS)
                INS (MOVE 2 , 0 (2))
                    (HRRI 1 , -3 (NP))
                    (PUSH NP , 1)
                    (ANDI 2 , 400000Q)
                    (PUSH NP , 2))              (* Construct bit table 
                                                from list of character 
                                                codes.)
      L2  (COND
            ((NLISTP L)
              (GO L1)))
          (ASSEMBLE NIL
                    (CQ (VAG (LOGAND (OR (NUMBERP (CAR L))
                                         (CHCON1 (CAR L)))
                                     177Q)))
                    (MOVE 2 , 1)
                    (IDIVI 2 , 44Q)
                    (MOVE 1 , @ -1 (NP))
                    (ROT 1 , 0 (3))
                    (TLO 1 , 400000Q)
                    (TSC 1 , 0 (NP))
                    (MOVN 3 , 3)
                    (ROT 1 , 0 (3))
                    (MOVEM 1 , @ -1 (NP)))
          (SETQ L (CDR L))
          (GO L2)                               (* Construct byte 
                                                pointer and byte count 
                                                for atom or string.)
      L1                                        (* Compute starting byte
                                                number and save on 
                                                number stack, replacing 
                                                NEG flag.)
          (ASSEMBLE NIL
                    (SETZM 0 (NP))
                    (CQ START)
                    (CAMN 1 , ' NIL)
                    (JRST CC)
                    (CQ (VAG (AC)))
                    (SUBI 1 , 1)
                    (MOVEM 1 , 0 (NP))
                    (JUMPGE 1 , CC)
                    (CQ (VAG (IPLUS (NCHARS STR)
                                    START)))
                    (MOVEM 1 , 0 (NP))
                CC)
          (COND
            ((STRINGP STR)
              (ASSEMBLE NIL
                        (CQ STR)
                        (MOVE 1 , 0 (1))
                        (LDB 4 , = 251700000001Q)
                        (TLZ 1 , 777770Q)
                        (IDIVI 1 , 5)
                        (IMUL 2 , = -70000Q)
                        (ADDI 2 , 440700Q)
                        (HRL 1 , 2)))
            ((LITATOM STR)
              (ASSEMBLE NIL
                        (CQ STR)
                        (HLRZ 1 , 2 (1))
                        (HRLI 1 , 440700Q)
                        (ILDB 4 , 1)))
            (T (SETQ STR (MKSTRING STR))
               (GO L1)))                        (* Now have byte pointer
                                                in 1, count in 4)
          (RETURN (ASSEMBLE NIL
                            (POP NP , 2)
                            (JUMPL 2 , NO)
                            (SUB 4 , 2)
                            (JUMPLE 4 , NO)
                            (MOVN 4 , 4)
                            (HRLZ 4 , 4)
                            (JUMPE 2 , LP)      (* Start at other than 
                                                first character, must 
                                                increment byte pointer.)
                            (ADD 4 , 2)
                            (IDIVI 2 , 5)
                            (ADD 1 , 2)         (* Word part.
                                                Just do IBP's for byte 
                                                part)
                            (JUMPE 3 , LP)
                        LP1 (IBP 1)
                            (SOJG 3 , LP1)
                        LP  (ILDB 2 , 1)
                            (IDIVI 2 , 44Q)
                            (MOVE 2 , @ 0 (NP))
                            (ROT 2 , 0 (3))
                            (JUMPL 2 , YES)
                            (AOBJN 4 , LP)
                        NO  (CQ NIL)
                            (JRST OUT)
                        YES (HRRZ 1 , 4)
                            (ADDI 1 , 1)
                            (CQ (LOC (AC)))
                        OUT (SUB NP , = 5000005Q)))
                                                (* E (RADIX 10))
      ])
)
  (LISPXPRINT (QUOTE (STRPOSL))
              T)
STOP