|
| 1 | +; (LEFT-OUT/: MYTPLEVEL <SAV> STARTER TESTPPN <START/k>) |
| 2 | +(DECLARE (SPECIAL <READ>-LINE/# READPROMPT/# RUNNING/# BAD-INPUT-ATN WMI HAUNTSFNS OLDDAY OLDRUN NAME-ATN) |
| 3 | + (*FEXPR TRACE-FUNCTION CONTINUE <SENTENCE> START) |
| 4 | + (*EXPR WM RUN LOAD-TEST) |
| 5 | + (MAPEX T) |
| 6 | + (FIXSW T)) |
| 7 | + |
| 8 | +; THE FOLLOWING DISABLES INTERRUPTS |
| 9 | +(DEFUN READP NIL NIL) |
| 10 | + |
| 11 | +(DEFUN <GT> (CONSTANT ELM) (AND (NUMBERP ELM) (> ELM (CAR CONSTANT)))) |
| 12 | + |
| 13 | +(DEFUN <LT> (CONSTANT ELM) (AND (NUMBERP ELM) (< ELM (CAR CONSTANT)))) |
| 14 | + |
| 15 | +;(DEFUN <TIME-INCR> FEXPR (L) |
| 16 | +; (PROG (EXTIME D1 D2 I1 time) |
| 17 | +; (SETQ EXTIME (EXPLODEC (CAR (SETQ L (APPLY 'EVAL-LIST L))))) |
| 18 | +; (SETQ D1 (READLIST (LIST (CAR EXTIME) (CADR EXTIME)))) |
| 19 | +; (SETQ D2 (READLIST (LIST (CADDDR EXTIME) (CAR (CDDDDR EXTIME))))) |
| 20 | +; (SETQ D2 (+ D2 (CADR L))) |
| 21 | +; (SETQ I1 (// D2 60.)) |
| 22 | +; (SETQ D2 (\ D2 60.)) |
| 23 | +; (SETQ D1 (\ (+ D1 I1) 24.)) |
| 24 | +; (RETURN (NCONS (READLIST (CONS '// |
| 25 | +; (APPEND (COND ((< D1 10.) (CONS '/0 (EXPLODE D1))) |
| 26 | +; (T (EXPLODE D1))) |
| 27 | +; '(// /:) |
| 28 | +; (COND ((< D2 10.) (CONS '/0 (EXPLODE D2))) |
| 29 | +; (T (EXPLODE D2)))))))))) |
| 30 | + |
| 31 | +(DEFUN <TIME-INCR> FEXPR (L) |
| 32 | + (PROG (EXTIME D1 D2 I1 time *nopoint ibase) |
| 33 | + (setq *nopoint t) |
| 34 | + (setq ibase 10.) |
| 35 | + (SETQ EXTIME (EXPLODEC (CAR (SETQ L (APPLY 'EVAL-LIST L))))) |
| 36 | + (setq d1 (readlist (list (nth 0 extime) (nth 1 extime)))) |
| 37 | + (setq d2 (readlist (list (nth 3 extime) (nth 4 extime)))) |
| 38 | + (SETQ D2 (+ D2 (CADR L))) |
| 39 | + (SETQ I1 (// D2 60.)) |
| 40 | + (SETQ D2 (\ D2 60.)) |
| 41 | + (SETQ D1 (\ (+ D1 I1) 24.)) |
| 42 | + (setq time (format nil "~2,48d:~2,48d" d1 d2)) |
| 43 | + (return (ncons (readlist (reverse (cdr (reverse (cdr (explode time)))))))))) |
| 44 | + |
| 45 | +(DEFUN <RAN> FEXPR (L) (LIST (RANDOM 9.))) |
| 46 | + |
| 47 | +(DEFUN <WRONG> FEXPR (L) (<SENTENCE> BAD-INPUT-ATN)) |
| 48 | + |
| 49 | +(DEFUN <EXIT> FEXPR (L) |
| 50 | + (PROG NIL |
| 51 | + L1 (QUIT) |
| 52 | + (TERPRI) |
| 53 | + (PRINC '|Not to be continued.|) |
| 54 | + (TERPRI) |
| 55 | + (GO L1))) |
| 56 | + |
| 57 | +;(DEFUN <EXIT> FEXPR (L) |
| 58 | +; (break l)) |
| 59 | + |
| 60 | +(DEFUN NEWSYS SLXN |
| 61 | + (PROG (SYSTEM-NAME STARTUP-FUNCTION) |
| 62 | + (SETQ SYSTEM-NAME (ARG 1.)) |
| 63 | + (COND ((= SLXN 2.) (SETQ STARTUP-FUNCTION (ARG 2.)))) |
| 64 | + (SUSPEND) |
| 65 | + (AND STARTUP-FUNCTION (FUNCALL STARTUP-FUNCTION)) |
| 66 | + (RETURN 'READY))) |
| 67 | + |
| 68 | +(DEFUN RANDPOS (LENGTH) (RANDOM LENGTH)) |
| 69 | + |
| 70 | +(DEFUN MANYPRINQ FEXPR (PL) (MAPC (FUNCTION (LAMBDA (PLONE) (PRINC PLONE))) PL)) |
| 71 | + |
| 72 | +(DEFUN FLATN (L) |
| 73 | + (COND ((ATOM L) L) |
| 74 | + ((ATOM (CAR L)) (CONS (CAR L) (FLATN (CDR L)))) |
| 75 | + (T (APPEND (FLATN (CAR L)) (FLATN (CDR L)))))) |
| 76 | + |
| 77 | +(DEFUN TIN (WT) |
| 78 | + (COND ((ATOM WT) WT) |
| 79 | + ((NUMBERP (CAR WT)) (TIN (NTH (RANDPOS (CAR WT)) (CDR WT)))) |
| 80 | + (T (CONS (TIN (CAR WT)) (TIN (CDR WT)))))) |
| 81 | + |
| 82 | +(DEFUN COMPILE-TEMPLATE (TMPLT) |
| 83 | + (PROG (TEMP) |
| 84 | + (RETURN (COND ((EQ (TYPEP TMPLT) 'LIST) |
| 85 | + (COND ((EQ (CAR TMPLT) '/#) |
| 86 | + (SETQ TEMP |
| 87 | + (MAPDEL (FUNCTION NUMBERP) |
| 88 | + (APPLY 'APPEND |
| 89 | + (MAPCAR (FUNCTION (LAMBDA (DTMP) |
| 90 | + (SETQ DTMP (COMPILE-TEMPLATE DTMP)) |
| 91 | + (COND ((EQ (TYPEP DTMP) 'LIST) |
| 92 | + DTMP) |
| 93 | + (T (NCONS DTMP))))) |
| 94 | + (CDR TMPLT))))) |
| 95 | + (CONS (LENGTH TEMP) TEMP)) |
| 96 | + ((EQ (CAR TMPLT) '%) |
| 97 | + (SETQ TEMP (MAPCAR (FUNCTION COMPILE-TEMPLATE) (CDR TMPLT))) |
| 98 | + (CONS (LENGTH TEMP) TEMP)) |
| 99 | + (T (CONS (COMPILE-TEMPLATE (CAR TMPLT)) (COMPILE-TEMPLATE (CDR TMPLT)))))) |
| 100 | + ((NULL TMPLT) NIL) |
| 101 | + ((BOUNDP TMPLT) (COMPILE-TEMPLATE (EVAL TMPLT))) |
| 102 | + (T TMPLT))))) |
| 103 | + |
| 104 | +(DEFUN STRINGREAD NIL |
| 105 | + (PROG (STRLIST) |
| 106 | + (COND ((= (TYIPEEK) 13.) (TYI) (TERPRI) (RETURN NIL))) |
| 107 | + (SETQ STRLIST (NCONS (ASCII 124.))) |
| 108 | + LAB (COND ((= (TYIPEEK) 13.) (TYI) (TYI) (RETURN (MAKNAM (NREVERSE (CONS (ASCII 124.) STRLIST))))) |
| 109 | + (T (SETQ STRLIST (CONS (ASCII (TYI)) STRLIST)) (GO LAB))))) |
| 110 | + |
| 111 | +(DEFUN ADD-PHRASE (PHLN) |
| 112 | + (PROG (NPHS NPH) |
| 113 | + (SETQ NPHS NIL) |
| 114 | + (COND ((NOT (BOUNDP PHLN)) (SET PHLN '(%)))) |
| 115 | + LAB (PRINC '|Phrase/:|) |
| 116 | + (SETQ NPH (STRINGREAD)) |
| 117 | + (COND (NPH (SETQ NPHS (CONS NPH NPHS)) (GO LAB)) |
| 118 | + (T (SET PHLN (APPEND (EVAL PHLN) NPHS)))))) |
| 119 | + |
| 120 | +(DEFUN CHAT (ATL) (NTH (RANDPOS (LENGTH ATL)) ATL)) |
| 121 | + |
| 122 | +(DEFUN MAPDEL (PRED LST) |
| 123 | + (COND ((ATOM LST) LST) |
| 124 | + ((FUNCALL PRED (CAR LST)) (MAPDEL PRED (CDR LST))) |
| 125 | + (T (CONS (CAR LST) (MAPDEL PRED (CDR LST)))))) |
| 126 | + |
| 127 | +(DEFUN CAPITALIZE (WRD) |
| 128 | + (PROG (EWRD CHRNUM) |
| 129 | + (SETQ CHRNUM (GETCHARN WRD 2.)) |
| 130 | + (RETURN (COND ((AND (> CHRNUM 96.) (< CHRNUM 123.)) |
| 131 | + (READLIST (APPEND (NCONS (ASCII 124.)) |
| 132 | + (RPLACA (SETQ EWRD (EXPLODEC WRD)) |
| 133 | + (ASCII (- (CHRVAL (CAR EWRD)) 32.))) |
| 134 | + (NCONS (ASCII 124.))))) |
| 135 | + (T WRD))))) |
| 136 | + |
| 137 | +(DEFUN CHRVAL (X) (GETCHARN X 1.)) |
| 138 | + |
| 139 | +(DEFUN MY-STRING-APPEND FEXPR (STRINGS) |
| 140 | + (READLIST (APPEND (NCONS (ASCII 124.)) |
| 141 | + (DELETE (ASCII 124.) |
| 142 | + (MAPCAN (FUNCTION (LAMBDA (STR) |
| 143 | + (EXPLODEC (COND ((OR (BOUNDP STR) |
| 144 | + (EQ (TYPEP STR) 'LIST)) |
| 145 | + (EVAL STR)) |
| 146 | + (T STR))))) |
| 147 | + STRINGS)) |
| 148 | + (NCONS (ASCII 124.))))) |
| 149 | + |
| 150 | +(DEFUN <SENTENCE> FEXPR (AN) |
| 151 | + (PROG (UNCS) |
| 152 | + (SETQ UNCS (FLATN (TIN (EVAL (CAR AN))))) |
| 153 | + (RETURN (NCONS (APPLY 'MY-STRING-APPEND (CONS (CAPITALIZE (CAR UNCS)) (CDR UNCS))))))) |
| 154 | + |
| 155 | +(DEFUN <CAPTOSM> FEXPR (LN) |
| 156 | + (MAPCAR (FUNCTION (LAMBDA (WD) |
| 157 | + (READLIST (APPEND (NCONS (ASCII 124.)) |
| 158 | + (MAPCAR (FUNCTION (LAMBDA (CHR) |
| 159 | + (COND ((AND (> CHR 64.) (< CHR 91.)) |
| 160 | + (ASCII (+ CHR 32.))) |
| 161 | + (T (ASCII CHR))))) |
| 162 | + (MAPCAR (FUNCTION CHRVAL) (EXPLODE WD))) |
| 163 | + (NCONS (ASCII 124.)))))) |
| 164 | + (APPLY 'EVAL-LIST LN))) |
| 165 | + |
| 166 | +(DEFUN OPS-READ** NIL |
| 167 | + (PROG (INL IC) |
| 168 | + (PRINC '*) |
| 169 | + (SETQ INL NIL) |
| 170 | + LAB (SETQ IC (TYI)) |
| 171 | + (SETQ INL (CONS IC INL)) |
| 172 | + (COND ;;((= IC #\return) (RETURN (NREVERSE (CONS 26. INL)))) |
| 173 | + ((= IC 13.) ; <CR> |
| 174 | + (RETURN (NREVERSE (CONS 26. INL)))) |
| 175 | + ((MEMBER IC '(127. 8.)) (SETQ INL (CDDR INL)) (TYO 8.) (PRINC '| |) (TYO 8.)) |
| 176 | + ((= IC 18.) |
| 177 | + (SETQ INL (CDR INL)) |
| 178 | + (tyo 8) |
| 179 | + (tyo 8) |
| 180 | + (princ '| |) |
| 181 | + (tyo 8) |
| 182 | + (tyo 8) |
| 183 | + (terpri) |
| 184 | + (mapc '(lambda (x) (princ (ascii x))) (reverse inl))) |
| 185 | +; ((= IC #\ctrl-t) |
| 186 | + ((= IC 24.) ; control-t) |
| 187 | + (SETQ INL (CDR INL)) |
| 188 | + (tyo 8) |
| 189 | + (tyo 8) |
| 190 | + (PRINc '|DAY/: |) |
| 191 | + (DAY) |
| 192 | + (princ '| RUN/: |) |
| 193 | + (RUN) |
| 194 | + (PRINC '| RD/:0 WR/:0 HAUNT 243+85P TI PC/:413102|) |
| 195 | + (TERPRI) (PRINC '|INPUT WAIT FOR TTY14|) |
| 196 | + (TERPRI)) |
| 197 | + ((= ic 21.) (setq inl nil) (princ '|^U|) (terpri)) |
| 198 | + ((< IC 27.) (SETQ INL (CDR INL))) |
| 199 | + ((MEMBER IC '(124. 39.)) (SETQ INL (CDR INL)))) |
| 200 | + (GO LAB))) |
| 201 | + |
| 202 | +(DEFUN DAY NIL |
| 203 | + (PROG (MIN SEC CENTI-SEC) |
| 204 | + (SETQ CENTI-SEC |
| 205 | + (- (- OLDDAY (SETQ OLDDAY (IFIX (*$ (TIME) 100.0)))))) |
| 206 | + (SETQ MIN (// CENTI-SEC 6000.)) |
| 207 | + (SETQ SEC (// (\ CENTI-SEC 6000.) 100.)) |
| 208 | + (SETQ CENTI-SEC (\ CENTI-SEC 100.)) |
| 209 | + (COND ((= MIN 0.) (PRINC SEC) (PRINC '|.|) (PRINC CENTI-SEC)) |
| 210 | + (T |
| 211 | + (PRINC '/:) |
| 212 | + (COND ((NULL (CDR (EXPLODEN MIN))) (PRINC '/0))) |
| 213 | + (PRINC MIN) |
| 214 | + (PRINC '/:) |
| 215 | + (PRINC SEC))))) |
| 216 | + |
| 217 | +(DEFUN RUN NIL |
| 218 | + (PROG (MICRO TEMP) |
| 219 | + (SETQ MICRO (- (- OLDRUN (SETQ OLDRUN (RUNTIME))))) |
| 220 | + (PRINC (// MICRO 1000000.)) |
| 221 | + (PRINC '|.|) |
| 222 | + (SETQ TEMP (// MICRO 10000.)) |
| 223 | + (COND ((NULL (CDR (SETQ TEMP (EXPLODEC TEMP)))) |
| 224 | + (SETQ TEMP (CONS '/0 TEMP)))) |
| 225 | + (COND ((CDDR TEMP) (RPLACD (CDR TEMP) NIL))) |
| 226 | + (MAPC 'PRINC TEMP))) |
| 227 | + |
| 228 | +(DEFUN BEGIN NIL |
| 229 | + (PROG NIL |
| 230 | + (START 'START) |
| 231 | + (LINEL T 79.) |
| 232 | + (SSTATUS TOPLEVEL |
| 233 | + '(COND((EQ (STATUS XUNAME) 'ejs) |
| 234 | + (print '*) |
| 235 | + (print (eval (read)))) |
| 236 | + (T (<exit>)))) |
| 237 | + (NOINTERRUPT T) |
| 238 | + (and (filep uread) (close uread)) |
| 239 | + (and (filep infile) (not (eq infile tyi)) (close infile)) |
| 240 | + (setq infile 'T) |
| 241 | + (SUSPEND) |
| 242 | + (NOINTERRUPT T) |
| 243 | + (cond ((eq (status XUNAME) 'ejs) (nointerrupt nil))) |
| 244 | + (cond ((not (eq (status XUNAME) 'ejs)) |
| 245 | + (SETQ UNBND-VRBL 'error-exit |
| 246 | + UNDF-FNCTN 'error-exit |
| 247 | + FAIL-ACT 'error-exit |
| 248 | + UNSEEN-GO-TAG 'error-exit |
| 249 | + WRNG-TYPE-ARG 'error-exit |
| 250 | + WRNG-NO-ARGS 'error-exit |
| 251 | + IO-LOSSAGE 'error-exit |
| 252 | + *RSET-TRAP 'error-exit |
| 253 | + MACHINE-ERROR 'error-exit |
| 254 | + GC-LOSSAGE 'error-exit |
| 255 | + PDL-OVERFLOW 'error-exit))) |
| 256 | + (DO X (CADDR (STATUS DAYTIME)) (1- X) (< X 0.) (RANDOM)) |
| 257 | + (SETQ OLDDAY (IFIX (*$ (TIME) 100.0))) |
| 258 | + (SETQ OLDRUN (RUNTIME)) |
| 259 | + (LINEL T 79.) |
| 260 | + (CONTINUE 'XYZZY))) |
| 261 | + |
| 262 | +(DEFUN XBEGIN NIL |
| 263 | + (PROG NIL |
| 264 | + (START 'START) |
| 265 | + (LINEL T 79.) |
| 266 | + (SSTATUS TOPLEVEL |
| 267 | + '(COND((EQ (STATUS XUNAME) 'ejs) |
| 268 | + (print '*) |
| 269 | + (print (eval (read)))) |
| 270 | + (T (<exit>)))) |
| 271 | + (NOINTERRUPT T) |
| 272 | + (cond ((eq (status XUNAME) 'ejs) (nointerrupt nil))) |
| 273 | + (cond ((not (eq (status XUNAME) 'ejs)) |
| 274 | + (SETQ UNBND-VRBL 'error-exit |
| 275 | + UNDF-FNCTN 'error-exit |
| 276 | + FAIL-ACT 'error-exit |
| 277 | + UNSEEN-GO-TAG 'error-exit |
| 278 | + WRNG-TYPE-ARG 'error-exit |
| 279 | + WRNG-NO-ARGS 'error-exit |
| 280 | + IO-LOSSAGE 'error-exit |
| 281 | + *RSET-TRAP 'error-exit |
| 282 | + MACHINE-ERROR 'error-exit |
| 283 | + GC-LOSSAGE 'error-exit |
| 284 | + GC-OVERFLOW 'error-exit |
| 285 | + PDL-OVERFLOW 'error-exit))) |
| 286 | + (DO X (CADDR (STATUS DAYTIME)) (1- X) (< X 0.) (RANDOM)) |
| 287 | + (SETQ OLDDAY (IFIX (*$ (TIME) 100.0))) |
| 288 | + (SETQ OLDRUN (RUNTIME)) |
| 289 | + (LINEL T 79.) |
| 290 | + (CONTINUE 'XYZZY))) |
| 291 | + |
| 292 | +(defun error-exit (x) (<exit>)) |
| 293 | + |
0 commit comments