Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-01 - 43,50151/docpgm.lsp
There are 2 other files named docpgm.lsp in the archive. Click here to see a list.
(DEFPROP ADVANCE
	 (LAMBDA NIL (RPLACA (CDAR RULES) (COND ((NULL (CDADAR RULES)) (CDDAR RULES)) ((CDADAR RULES)))))
 	 EXPR)
NIL 

(DEFPROP ANALYZE
	 (LAMBDA NIL
	  (PROG (RULES PARSELIST DECOMP)
		(SETQ KEYSTACK
		      (APPEND KEYSTACK
			      (LIST
			       (GET (QUOTE NONE)
				    (COND
				     ((ZEROP (SETQ FLIPFLOP (PLUS 2 (MINUS FLIPFLOP)))) (QUOTE MEM))
				     ((QUOTE LASTRESORT)))))))
 	   A    (SETQ RULES (GET (CAR KEYSTACK) (QUOTE RULES)))
 	   B    (SETQ DECOMP
		      (CAAR (COND ((ATOM (CAR RULES)) (SETQ RULES (GET (CAR RULES) (QUOTE RULES)))) (RULES))))
		(SETQ PARSELIST NIL)
		(COND ((NOT (TEST DECOMP SENTENCE)) (SETQ RULES (CDR RULES)))
		      ((AND (NOT (ATOM (CAR (SETQ RULES (CAR (ADVANCE))))))
			    (NOT (EQ (CAAR RULES) (QUOTE PRE))))
		       (RETURN (SENTPRINT (RECONSTRUCT (CAR RULES)))))
		      ((NOT (ATOM (CAR RULES))) (SETQ SENTENCE (RECONSTRUCT (CADAR RULES)))
						(SETQ RULES (CDDAR RULES)))
		      ((EQ (CAR RULES) (QUOTE NEWKEY)) (SETQ KEYSTACK (CDR KEYSTACK)) (GO A)))
		(GO B)))
 	 EXPR)
NIL 

(DEFPROP BREAKANALYZE
	 (LAMBDA NIL
	  (COND ((EQ LETTER (INTERN (ASCII 15))) (SETQ FLAG TERMINAL) (SETQ TERMINAL T))
		((AND (SETQ FLAG (GET LETTER (QUOTE PUNCTUATION))) KEYSTACK) (GOBBLE))
		(FLAG (SETQ SENTENCE (SETQ FLAG NIL)))
		((NOT (EQ LETTER (INTERN (ASCII 12)))) (SETQ TERMINAL NIL))))
 	 EXPR)
NIL 

(DEFPROP CLEANUP
	 (LAMBDA NIL
	  (PROG (NOBLIST)
		(SETQ NOBLIST OBLIST)
 	   A    (RPLACA NOBLIST (CAR SOBLIST))
		(COND ((SETQ NOBLIST (CDR NOBLIST)) (SETQ SOBLIST (CDR SOBLIST)) (GO A)))))
 	 EXPR)
NIL 

(DEFPROP GOBBLE
	 (LAMBDA NIL (PROG NIL A (SETQ LETTER (READLIST (LIST (QUOTE //) (READCH)))) (BREAKANALYZE) (COND ((NOT FLAG) (GO A)))))
 	 EXPR)
NIL 

(DEFPROP INITIALIZE (LAMBDA NIL (SETQ SOBLIST (APPEND OBLIST (SETQ SENTENCE (SETQ KEYSTACK NIL))))) EXPR)

(DEFPROP MAKESENTENCE
	 (LAMBDA NIL
	  (SETQ SENTENCE (CONS (COND ((SETQ FLAG (GET WORD (QUOTE TRANSLATION))) FLAG) (WORD)) SENTENCE)))
 	 EXPR)
NIL 

(DEFPROP MEMORY
	 (LAMBDA NIL
	  (PROG (PARSELIST X)
		(COND
		 ((AND (SETQ RULES (GET (CAR KEYSTACK) (QUOTE MEMR))) (TEST (CAAR RULES) SENTENCE))
		  (RPLACA (SETQ X (CDAR (GET (GET (QUOTE NONE) (QUOTE MEM)) (QUOTE RULES))))
			  (APPEND (CAR X) (LIST (RECONSTRUCT (CAAR (ADVANCE))))))))))
 	 EXPR)
NIL 

(DEFPROP PRIN2
	 (LAMBDA(X)
	  (PROG NIL
		(SETQ OBASE 13)
 	   A    (COND ((NULL X) (RETURN (SETQ OBASE 12)))
		      ((EQ (CAR X) (QUOTE //)) (PRINC (CADR X)) (SETQ X (CDDR X)))
		      ((PRIN1 (CAR X)) (SETQ X (CDR X))))
		(GO A)))
 	 EXPR)
NIL 

(DEFPROP READIN
	 (LAMBDA NIL
	  (PROG (WORD LETTER FLAG TERMINAL)
 	   A    (COND ((NULL (READWORD)) (GO B)))
		(MAKESENTENCE)
		(SETKEYSTACK)
 	   B    (BREAKANALYZE)
		(COND ((NOT FLAG) (GO A)))
		(SETQ SENTENCE (REVERSE SENTENCE))))
 	 EXPR)
NIL 

(DEFPROP READWORD
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ WORD NIL)
 	   A    (COND
		 ((SETQ FLAG (GET (SETQ LETTER (READLIST (LIST (QUOTE //) (READCH)))) (QUOTE BREAK)))
		  (RETURN (COND (WORD (SETQ WORD (READLIST (CONS (QUOTE //) (REVERSE WORD)))))))))
		(SETQ WORD (CONS LETTER WORD))
		(GO A)))
 	 EXPR)
NIL 

(DEFPROP RECONSTRUCT
	 (LAMBDA(R)
	  (COND ((NULL R) NIL)
		((NUMBERP (CAR R)) (APPEND (RECO1 (CAR R) PARSELIST) (RECONSTRUCT (CDR R))))
		((CONS (CAR R) (RECONSTRUCT (CDR R))))))
 	 EXPR)
NIL 

(DEFPROP RECO1 (LAMBDA (X P) (COND ((GREATERP X 1) (RECO1 (SUB1 X) (CDR P))) ((CAR P)))) EXPR)
(DEFPROP SENTPRINT
	 (LAMBDA(ANS)
	  (PROG NIL
 	   A    (PRIN2 (EXPLODE (CAR ANS)))
		(COND
		 ((SETQ ANS (CDR ANS))
		  (COND ((GREATERP (FLATSIZE (CAR ANS)) (SUB1 (CHRCT))) (TERPRI)) ((PRINC (QUOTE / ))))
		  (GO A)))
		(MEMORY)))
 	 EXPR)
NIL 

(DEFPROP SETKEYSTACK
	 (LAMBDA NIL
	  (COND
	   ((AND (SETQ FLAG (GET WORD (QUOTE PRIORITY)))
 		 KEYSTACK
		 (GREATERP FLAG (GET (CAR KEYSTACK) (QUOTE PRIORITY))))
	    (SETQ KEYSTACK (CONS WORD KEYSTACK)))
	   (FLAG (SETQ KEYSTACK (APPEND KEYSTACK (LIST WORD))))))
 	 EXPR)
NIL 

(DEFPROP TEST
	 (LAMBDA(D S)
	  (PROG NIL
 	   G    (COND ((NULL D) (RETURN (COND ((NOT S) (SETQ PARSELIST (REVERSE PARSELIST))))))
		      ((NOT
			(COND ((NUMBERP (CAR D)) (COND ((ZEROP (CAR D)) (TEST5)) ((TEST3 (CAR D) NIL))))
			      ((TEST4 (CAR D)) (TEST2))))
		       (RETURN NIL)))
		(SETQ D (CDR D))
		(GO G)))
 	 EXPR)
NIL 

(DEFPROP TEST1
	 (LAMBDA (PROPL X) (COND ((NULL PROPL) NIL) ((GET X (CAR PROPL)) T) ((TEST1 (CDR PROPL) X))))
 	 EXPR)
NIL 

(DEFPROP TEST2
	 (LAMBDA NIL (PROG NIL (SETQ PARSELIST (CONS (LIST (CAR S)) PARSELIST)) (SETQ S (CDR S)) (RETURN T)))
 	 EXPR)
NIL 

(DEFPROP TEST3
	 (LAMBDA(X L)
	  (COND ((ZEROP X) (SETQ PARSELIST (CONS (REVERSE L) PARSELIST)))
		(S (TEST3 (SUB1 X) (CONS (CAR S) (PROG2 (SETQ S (CDR S)) L))))))
 	 EXPR)
NIL 

(DEFPROP TEST4
	 (LAMBDA(D)
	  (COND ((NULL S) NIL)
		((ATOM D) (EQ D (CAR S)))
		((CAR D) (MEMBER (CAR S) D))
		((TEST1 (CDR D) (CAR S)))))
 	 EXPR)
NIL 

(DEFPROP TEST5
	 (LAMBDA NIL
	  (PROG (L X)
		(COND ((NULL (CDR D)) (SETQ PARSELIST (CONS S PARSELIST)) (RETURN (NOT (SETQ S NIL)))))
 	   A    (COND ((SETQ X (PROG (PARSELIST) (RETURN (TEST (CDR D) S)))) (SETQ D (LIST (SETQ S NIL)))
									     (RETURN
									      (SETQ PARSELIST
										    (NCONC
										     (REVERSE
										      (CONS (REVERSE L) X))
										     PARSELIST))))
		      ((AND (SETQ L (CONS (CAR S) L)) (SETQ S (CDR S))) (GO A)))))
 	 EXPR)
NIL 

(DEFPROP WORKER
	 (LAMBDA NIL
	  (PROG (SENTENCE SOBLIST KEYSTACK)
 	   A    (INITIALIZE)
		(READIN)
		(ANALYZE)
		(TERPRI)
		(TERPRI)
		(CLEANUP)
		(GO A)))
 	 EXPR)
NIL