PDP-10.its/src/inquir/reader.28

;;; -*- LISP -*-î
î
(EVAL-WHEN (EVAL COMPILE) (LOAD '((LIBLSP) TTY FASL)))î
î
(DECLARE (SPECIAL INITIAL-TTY-SPECIFICATIONS SMART-TTY))î
î
(DECLARE (*LEXPR WHERE-TTY-SHOULD-BE))î
î
(COND ((NOT (BOUNDP 'SMART-TTY))î
       (SETQ SMART-TTY (NOT (NOT (MEMQ 'CURSORPOS (STATUS FILEM TYO)))))))î
î
(DEFUN SMART-TTY? () SMART-TTY)î
î
(DEFUN BACK-UP-AND-OVERSTRIKE (POS)î
       (LET ((INITIAL-POS (CDR (CURSORPOS))))î
	    (COND ((= INITIAL-POS POS)î
		   (TYO 10. TYO))î
		  ((> INITIAL-POS POS)î
		   (DO ((I INITIAL-POS (1- I)))î
		       ((= I POS) T)î
		       (TYO 8. TYO)î
		       (TYO 92. TYO)î
		       (TYO 8. TYO)))î
		  (Tî
		   (TYO 10. TYO)î
		   (DO ((I INITIAL-POS (1+ I)))î
		       ((= I POS) T)î
		       (TYO 32. TYO))))))î
î
(DEFUN FANCY-RUBOUT (POS CHAR)î
;       ((LAMBDA (CURRENT) ;debugging codeî
;		(CURSORPOS 23. 0. TYO)î
;		(PRINC (LIST 'POS= POS 'ASCII= CHAR) TYO)î
;		(PRINC '| --MORE--| TYO)î
;		(TYI TYI)î
;		(CURSORPOS 23. 0. TYO)î
;		(CURSORPOS 'L TYO)î
;		(CURSORPOS (CAR CURRENT) (CDR CURRENT) TYO))î
;	(CURSORPOS))î
       (COND ((= CHAR 10.)î
	      (CURSORPOS 'U TYO)î
	      (CURSORPOS 'L TYO))î
	     ((= CHAR 13.)î
	      (CURSORPOS (1- (CAR (CURSORPOS))) POS)î
	      (CURSORPOS 'L TYO))î
	     (Tî
	      (CURSORPOS NIL POS TYO)î
	      (CURSORPOS 'L TYO))))î
î
(DEFUN READER$RUBOUT (POS SMART-FLAG CHAR)î
       (COND (SMART-FLAG (FANCY-RUBOUT POS CHAR))î
	     (T (BACK-UP-AND-OVERSTRIKE POS))))î
î
(DEFUN REDISPLAY (LINE PROMPT) (REDISPLAY1 LINE PROMPT))î
î
(DEFUN REDISPLAY1 (LINE PROMPT)î
       (COND ((ANDî
	       (SMART-TTY?)î
	       (EQ (CAR (WHERE-TTY-SHOULD-BE)) (CAR (CURSORPOS))))î
	      (CURSORPOS NIL 0. TYO)î
	      (CURSORPOS 'L TYO))î
	     (T (CURSORPOS 'A TYO)))î
       (COND (PROMPT (PRINC PROMPT TYO))î
	     (T (CURSORPOS NIL (CDAR (LAST LINE)) TYO)))î
       (DO ((L (REVERSE LINE) (CDR L)))î
	   ((NULL L))î
	   (COND ((ATOM (CAR L))î
		  (CURSORPOS NIL (LINEL TYO) TYO)î
		  (PRINC '- TYO)î
		  (TERPRI TYO))î
		 (Tî
		  (RPLACD (CAR L) (CDR (CURSORPOS TYO)))î
		  (TYO (CAAR L) TYO))))î
       (WHERE-TTY-SHOULD-BE (CURSORPOS TYO)))î
î
(DEFUN SCROD-DISPLAY () (NOT (EQUAL (WHERE-TTY-SHOULD-BE) (CURSORPOS TYO))))î
î
(DEFUN WHERE-TTY-SHOULD-BE Xî
       (COND ((ZEROP X) (GET 'INPUT-LINE 'WHERE-TTY-SHOULD-BE))î
	     ((= X 1.) (PUTPROP 'INPUT-LINE (ARG 1) 'WHERE-TTY-SHOULD-BE))î
	     (T (BREAK |(Wrong Number of Args to WHERE-TTY-SHOULD-BE)|))))î
î
(DEFUN ONE-LINE-ONLY (LINE)î
       (DO ((L LINE (CDR L))î
	    (A NIL))î
	   ((NULL L) (REVERSE A))î
	   (COND ((OR (EQ (CAR L) '<CR>)î
		      (MEMBER (CAAR L) '(13. 10.)))î
		  (RETURN (REVERSE A)))î
		 (T (SETQ A (CONS (CAR L) A))))))î
î
(DEFUN RUBBING-OUT @î
       (COND ((ZEROP @) (GET 'INPUT-LINE 'RUBBING-OUT))î
	     (T (PUTPROP 'INPUT-LINE (ARG 1) 'RUBBING-OUT))))î
î
(SSTATUS TTYINT 23. NIL)î
î
(DEFUN READER$DELETE (LINE PROMPT)î
       (PROG (POS CHAR)î
	     (COND ((NULL LINE)î
		    (PRINC (ASCII 7.) TYO)î
		    (RETURN NIL)))î
	     (COND ((ATOM (CAR LINE))î
		    (CURSORPOS (1- (CAR (CURSORPOS))) (1- (LINEL TYO)) TYO)î
		    (WHERE-TTY-SHOULD-BE (CURSORPOS))î
		    (SETQ LINE (CDR LINE))))î
	     (SETQ POS (CDAR LINE))î
	     (SETQ CHAR (CAAR LINE))î
	     (SETQ LINE (CDR LINE))î
	     (COND ((SCROD-DISPLAY) (REDISPLAY LINE PROMPT))î
		   (Tî
		    (READER$RUBOUT POS (SMART-TTY?) CHAR)))î
	     (WHERE-TTY-SHOULD-BE (CURSORPOS))î
	     (RUBBING-OUT T)î
	     (RETURN LINE)))î
î
(DEFUN ADD (CHAR LINE PROMPT)î
       (PROG (POS)î
	     (SETQ POS (CDAR LINE))î
	     (COND ((SCROD-DISPLAY) (REDISPLAY LINE PROMPT)))î
	     (COND ((> (+ (FLATC (ASCII CHAR)) (CDR (CURSORPOS)))î
		       (LINEL TYO))î
		    (CURSORPOS NIL (LINEL TYO) TYO)î
		    (PRINC '- TYO)î
		    (TERPRI TYO)î
		    (SETQ LINE (CONS '<CR> LINE))))î
	     (SETQ LINE (CONS (CONS CHAR (CDR (CURSORPOS))) LINE))î
	     (COND ((RUBBING-OUT) (UPDATE-DISPLAY)))î
	     (RUBBING-OUT NIL)î
	     (TYO CHAR TYO)î
	     (RETURN LINE)))î
î
(DEFUN UPDATE-DISPLAY ()î
       (COND ((NOT (SMART-TTY?)) (TYO 10. TYO))))î
î
(DEFUN CLEAR-SCREEN ()î
       (CURSORPOS 'C TYO))î
î
(DEFUN LINE-READ-A-NUMBER (PROMPT TYPE)î
       (PROG (NUM)î
	     TOPî
	     (SETQ NUM (READER PROMPT '(13.)))î
	     (SETQ NUMî
		   (CARî
		    (ERRSET (READLIST (DELETE '| | NUM))î
			    NIL)))î
	     (COND ((NUMBERP NUM)î
		    (RETURN (COND (TYPE (FUNCALL TYPE NUM))î
				  (T NUM))))î
		   (Tî
		    (CURSORPOS 'A TYO)î
		    (PRINC '|Data must be numeric. Please retry.| TYO)î
		    (CURSORPOS 'A TYO)î
		    (GO TOP)))))î
î
(DEFUN READER (PROMPT TERMINAL)î
       (DO-WITH-TTY-OFFî
	(PROG (TEMP)î
	      (PRINC PROMPT TYO)î
	      (WHERE-TTY-SHOULD-BE (CURSORPOS))î
	      (SETQ TEMPî
		    (DO ((C (TYI TYI) (TYI TYI))î
			 (LINE NIL))î
			((MEMBER C TERMINAL) LINE)î
			(COND ((= C 127.)î
			       (SETQ LINE (READER$DELETE LINE PROMPT)))î
			      ((= C 12.)î
			       (CLEAR-SCREEN)î
			       (REDISPLAY LINE PROMPT))î
			      ((= C 18.)î
;			       ((LAMBDA (TEMP)î
;				 (CURSORPOS 12. 0. TYO)î
;				 (PRINT (LIST 'LINE= LINEî
;					      'ONE= (ONE-LINE-ONLY LINE)))î
;				 (CURSORPOS (CAR TEMP) (CDR TEMP) TYO))î
;			        (CURSORPOS))î
			       (REDISPLAY (ONE-LINE-ONLY LINE) NIL))î
			      ((= C 21.)î
			       (SETQ LINE (READER$FLUSH-LINE LINE PROMPT)))î
			      ((= C 23.)î
			       (SETQ LINE (READER$DELETE-WORD LINE PROMPT)))î
			      (T (SETQ LINE (ADD C LINE PROMPT))))î
			(WHERE-TTY-SHOULD-BE (CURSORPOS))))î
	      (SETQ TEMPî
		    (DO ((L TEMP (CDR L))î
			 (A NIL))î
			((NULL L) A)î
			(COND ((NOT (ATOM (CAR L)))î
			       (SETQ A (CONS (ASCII (CAAR L)) A))))))î
	      (RETURN TEMP))))î
î
(DEFUN READER$DELETE-WORD (LINE PROMPT)î
       (READER$FLUSH-ALPHA (READER$FLUSH-NON-ALPHA LINE PROMPT) PROMPT))î
î
(DEFUN READER$FLUSH-NON-ALPHA (LINE PROMPT)î
       (DO ((L LINE))î
	   ((OR (NULL L) (AND (NOT (ATOM (CAR L))) (ALPHAP (CAAR L)))) L)î
	   (SETQ L (READER$DELETE L PROMPT))î
	   (WHERE-TTY-SHOULD-BE (CURSORPOS))))î
î
(DEFUN READER$FLUSH-ALPHA (LINE PROMPT)î
       (DO ((L LINE))î
	   ((OR (NULL L) (ATOM (CAR L)) (NOT (ALPHAP (CAAR L)))) L)î
	   (SETQ L (READER$DELETE L PROMPT))î
	   (WHERE-TTY-SHOULD-BE (CURSORPOS))))î
î
(DEFUN READER$FLUSH-LINE (LINE PROMPT)î
       (DO ((L (AND LINE (READER$DELETE LINE PROMPT))î
	       (READER$DELETE L PROMPT)))î
	   ((OR (NULL L)î
		(AND (NOT (ATOM (CAR L))) (= (CAAR L) 13.)))î
	    L)))î
î
(DEFUN ALPHAP (X)î
       (AND (NUMBERP X)î
	    (OR (AND (> X 64.) (< X 91.))î
		(AND (> X 96.) (< X 123.)))))î
       î
(DEFUN READ-ALTMODE (PROMPT)î
       (IMPLODE (READER PROMPT '(27.))))î
î
(DEFUN READ-<CR> (PROMPT)î
       (IMPLODE (READER PROMPT '(13.))))î
î
(DEFUN READ-SPACE (PROMPT)î
       (IMPLODE (READER PROMPT '(32.))))î
î
(DEFUN R ()î
       (CURSORPOS 'A TYO)î
       (READER '|> | '(13.)))î
î
(DEFPROP READER T LOADED)