(* Filed on: {phylum}<desrivieres>nlisp>camel-top *)


(* There are 3 distinct processes involved:
   1. The EMACS top level for 3-lisp (exactly 1).
   2. The 3-lisp processor itself (exactly 1).
   3. The EMACS editor (any number). *)

(DEFINEQ (WIRE-3-LISP-KEYS (LAMBDA ()
  (PROG ()
    (KEYACTION 'BS 
       (CONS (LIST (CHARCODE ↑H) (CHARCODE ↑H) 'NOLOCKSHIFT) 'IGNORE))
    (IF (EQ 'DANELION (MACHINETYPE)) THEN
        (KEYACTION 'LOCK '(CRTLDOWN . CTRLUP))
        (KEYACTION 'TAB  '(METADOWN . METAUP))
        (KEYACTION '← 
          (CONS (LIST (CHARCODE \) (CHARCODE ↑) 'NOLOCKSHIFT) 'IGNORE))
        (KEYACTION 'CR 
          (CONS (LIST (CHARCODE CR) (CHARCODE LF) 'NOLOCKSHIFT) 'IGNORE))
        (KEYACTION 'STOP 
          (CONS (LIST (CHARCODE ↑G) (CHARCODE ↑G) 'NOLOCKSHIFT) 'IGNORE))
        (KEYACTION 'UNDO 
          (CONS (LIST (CHARCODE #A) (CHARCODE #A) 'NOLOCKSHIFT) 'IGNORE))
     ELSE
        (KEYACTION 'BLANK-BOTTOM '(METADOWN . METAUP))) 
    (RETURN)))))

(DEFINEQ (LOAD.PATCHES (LAMBDA ()
 (NLSETQ
  (PROG (NAME)
    (* Called immediately after the 3-LISP sysout is restarted. *)
    (* Go to the nearest file server and try to find some patchs. *)
    (FOR NAME IN PATCHFILES DO
       (ERSETQ (LOAD NAME T)))
    (RETURN))))))

(GLOBALVARS INPUTQMONITOR OUTPUTQMONITOR INPUTQNONEMPTY
    OUTPUTQNONEMPTY INPUTQ OUTPUTQ SEND.MORE.CHUCK.BERRY)


(DEFINEQ (EMACS.FLASH (LAMBDA (STREAM POINT DURATION)
   (PROG ()
      (TEDIT.SETSEL STREAM (ADD1 (EMACS.GETFILEPTR STREAM)) 1 POINT T)
      (TEDIT.SHOWSEL STREAM T) 
      (DISMISS DURATION)))))


(DEFINEQ (\\COM.NORMALIZE.SEXPR.FORWARD (LAMBDA (STREAM)
   (PROG (EXP PTR)
     (SETQ PTR (EMACS.GETFILEPTR STREAM))
     (NLSETQ  
         (SETQ EXP 'NO.DICE)
         (SETQ EXP (DIGEST (READ STREAM NLISP-READ-TABLE))))
     (IF (EQ EXP 'NO.DICE) THEN
         (TEDIT.NOTIFY (LAST-ERROR-STRING) '(CLEARW))
         (RINGBELLS)
         (EMACS.FLASH STREAM 'RIGHT 1000)
         (EMACS.SETCARETPTR STREAM PTR)
      ELSE
         (EMACS.SETCARETPTR STREAM (EMACS.GETFILEPTR STREAM))
         (3LISP.NORMALIZE EXP STREAM))))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 1) '\\COM.NORMALIZE.SEXPR.FORWARD)

(DEFINEQ (\\COM.NORMALIZE.SEXPR.BACKWARDS (LAMBDA (STREAM)
   (PROG (EXP PTR)
     (SETQ PTR (EMACS.GETFILEPTR STREAM))
     (NLSETQ  
         (SETQ EXP 'NO.DICE)
         (EMACS.SEXPR.BACK STREAM)
         (EMACS.FLASH STREAM 'RIGHT 200)
         (SETQ EXP (DIGEST (READ STREAM NLISP-READ-TABLE))))
     (IF (EQ EXP 'NO.DICE) THEN
         (TEDIT.NOTIFY (LAST-ERROR-STRING) '(CLEARW))
         (RINGBELLS)
         (EMACS.FLASH STREAM 'RIGHT 1000)
         (EMACS.SETCARETPTR STREAM PTR)
      ELSE
         (EMACS.SETCARETPTR STREAM PTR)
         (3LISP.NORMALIZE EXP STREAM))))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 2) '\\COM.NORMALIZE.SEXPR.BACKWARDS)

(DEFINEQ (\\COM.NORMALIZE.DEFINITION (LAMBDA (STREAM)
   (PROG (EXP PTR)
     (SETQ PTR (EMACS.GETFILEPTR STREAM))
     (\\COM.TOP.OF.DEFINITION STREAM)
     (NLSETQ  
         (SETQ EXP 'NO.DICE)
         (EMACS.FLASH STREAM 'LEFT 200)
         (SETQ EXP (DIGEST (READ STREAM NLISP%-READ%-TABLE))))
     (IF (EQ EXP 'NO.DICE) THEN
         (TEDIT.NOTIFY (LAST-ERROR-STRING) '(CLEARW))
         (RINGBELLS)
         (EMACS.FLASH STREAM 'LEFT 1000)
         (EMACS.SETCARETPTR STREAM PTR)
      ELSE
         (EMACS.FLASH STREAM 'LEFT 200)
         (EMACS.SETCARETPTR STREAM PTR)
         (3LISP.NORMALIZE EXP STREAM))))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 3) '\\COM.NORMALIZE.DEFINITION)

(DEFINEQ (\\COM.DELETE.BUFFER (LAMBDA (STREAM)
   (EMACS.DELETE STREAM 0 (SUB1 (GETEOFPTR STREAM))))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 4) '\\COM.DELETE.BUFFER)

(DEFINEQ (\\COM.RESET.3LISP (LAMBDA ()
   (PROG (PROCESS WINDOW TEXTOBJ STREAM)
      (RINGBELLS)
      (CAUSE-NLISP-RESET)
      (SETQ PROCESS (THIS.PROCESS))
      (SETQ WINDOW (PROCESSPROP PROCESS 'WINDOW))
      (SETQ TEXTOBJ (AND WINDOW (TEXTOBJ WINDOW)))
      (SETQ STREAM (AND TEXTOBJ (FETCH STREAMHINT OF TEXTOBJ)))
      (* FLUSH ALL INPUT *)
      (WITH.MONITOR INPUTQMONITOR
         (SETQ INPUTQ (CONS NIL NIL)))
      (* Unwedge the processor. *)
      (SEND.TO.3LISP HOKAY)
      (* Flush all pending output too. *)
      (WITH.MONITOR OUTPUTQMONITOR
         (SETQ OUTPUTQ (CONS NIL NIL)))
      (IF (OR (NOT STREAM)
              (NOT (LISTGET (WINDOWPROP WINDOW 'TEDIT.PROPS)
                       'EMACSTOPLEVEL))) THEN
          (SEND.TO.EMACS 'STRUCTURE HOKAY)
          (ERROR!)
       ELSE
          (3LISP.SPIN STREAM))
      ))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 5) '\\COM.RESET.3LISP)

(SETQ TEDIT.INTERRUPTS
    (LIST (LIST (CHARCODE ↑C) (QUOTE HELP))
          (LIST (CHARCODE ↑G) (QUOTE ERROR))))

(EMACS.MAKE.↑X.COMMAND (CHARCODE 6) 'CAUSE-NLISP-BREAK)


(DEFINEQ (3LISP.NORMALIZE (LAMBDA (EXP STREAM)
   (IF (NOT
         (LISTGET
            (WINDOWPROP (FETCH \WINDOW OF (TEXTOBJ STREAM))
               'TEDIT.PROPS)
            'EMACSTOPLEVEL)) THEN
       (SEND.TO.EMACS 'STRUCTURE EXP)
       (SEND.TO.3LISP EXP)
     ELSE
       (SEND.TO.3LISP EXP)
       (3LISP.SPIN STREAM)))))
    

(* An editor's expressions are queued for normalization
   and echoing by the top level.  Does not wait for results. *)

(DEFINEQ (SEND.TO.3LISP (LAMBDA (EXP)
   (WITH.MONITOR INPUTQMONITOR
       (TCONC INPUTQ EXP)
       (NOTIFY.EVENT INPUTQNONEMPTY T))
   (BLOCK))))


(DEFINEQ (3LISP.SPIN (LAMBDA (STREAM)
   (PROG (EXP MORE.TO.PRINT DONE)
     LOOP
      (SETQ EXP 'NONE.TO.BE.HAD)
      (WITH.MONITOR OUTPUTQMONITOR
         (IF (NOT (NULL (CAR OUTPUTQ))) THEN             
             (SETQ EXP (CAR (CAR OUTPUTQ))) 
             (RPLACA OUTPUTQ (CDR (CAR OUTPUTQ)))
             (IF (NULL (CAR OUTPUTQ)) THEN
                 (RPLACD OUTPUTQ NIL))))
      (IF (NEQ EXP 'NONE.TO.BE.HAD) THEN          
          (PRINT.TO.STREAM STREAM EXP)
          (BLOCK)
          (GO LOOP))

      (WITH.MONITOR INPUTQMONITOR
         (SETQ DONE (AND SEND.MORE.CHUCK.BERRY
                         (NULL (CAR INPUTQ)))))

      (IF (NOT DONE) THEN
          (* Wait for him to hang. *)
          (WITH.MONITOR OUTPUTQMONITOR
              (IF (NULL (CAR OUTPUTQ)) THEN
                  (MONITOR.AWAIT.EVENT OUTPUTQMONITOR OUTPUTQNONEMPTY)))
          (GO LOOP)
       ELSE
          (\BOUT STREAM (CHARCODE %|)) 
          (RETURN))))))

(DEFINEQ (PRINT.TO.STREAM (LAMBDA (STREAM EXP)
  (PROG (EXP.TYPE EXP.BODY TEMP.STRING)
     (SETQ EXP.TYPE (CAR EXP))
     (SETQ EXP.BODY (CADR EXP))
     (SELECTQ EXP.TYPE
        (CHARACTER
            (\BOUT STREAM
                (FETCH (CHARACTER-DESIGNATOR CHARCODE) OF EXP.BODY)))
        (STRING
            (INSERT.LINES STREAM (EXTRACT-STRING EXP.BODY)))
        (STRUCTURE
            (SETQ TEMP.STRING (PP.TO.TEMP.STRING EXP.BODY))
            (INSERT.LINES STREAM TEMP.STRING))
        (SHOULDNT "Don't know how to display one of those. "))
     (RETURN)))))

(DEFINEQ (PP.TO.TEMP.STREAM (EXP)
  (PROG (TEMP.STREAM STRUCTURE SIZE RESULT)
     (SETQ TEMP.STREAM (OPENSTREAM '{CORE}PPSTREAM.TEMP 'BOTH 'NEW))
     (RESETVARS ((#RPARS NIL) (#CAREFULCOLUMNS 20) (PRETTYTABFLG NIL))
        (PRINTOUT TEMP.STREAM .PPV (PREPRINT EXP NIL)))
     (RETURN TEMP.STREAM))))

(DEFINEQ (PP.TO.TEMP.STRING (EXP)
  (PROG (TEMP.STREAM STRUCTURE SIZE RESULT)
     (SETQ TEMP.STREAM (OPENSTREAM '{CORE}PPSTREAM.TEMP 'BOTH 'NEW))
     (RESETVARS ((#RPARS NIL) (#CAREFULCOLUMNS 20) (PRETTYTABFLG NIL))
        (PRINTDEF (PREPRINT EXP NIL) NIL NIL NIL NIL TEMP.STREAM))
     (SETQ SIZE (GETEOFPTR TEMP.STREAM))
     (SETQ RESULT (ALLOCSTRING SIZE))
     (SETFILEPTR TEMP.STREAM 0)
     (FOR I FROM 1 TO SIZE DO
        (RPLCHARCODE RESULT I (\BIN TEMP.STREAM))) 
     (CLOSEF? TEMP.STREAM)
     (RETURN RESULT))))

(DEFINEQ (INSERT.LINES (STREAM STRING)
  (PROG (START P S)
    (* Done so that scrolling is smoother. *)
    (SETQ START 1)
   LOOP
     (SETQ P (STRPOS "
"
                  STRING START NIL NIL NIL))
     (SETQ S (SUBSTRING STRING START P))
     (TEDIT.INSERT STREAM S NIL NIL T)
     (IF (NULL P) THEN (RETURN))
     (SETQ START (ADD1 P))
     (GO LOOP))))
     

(DEFINEQ (START.3TOP (LAMBDA ()
  (PROG ()
   (SETQ EMACS.TOP.LEVEL T)
   (SETQ INPUTQMONITOR (CREATE.MONITORLOCK 'INPUTQMONITOR))
   (SETQ OUTPUTQMONITOR (CREATE.MONITORLOCK 'OUTPUTQMONITOR))
   (SETQ INPUTQNONEMPTY (CREATE.EVENT 'INPUTQNONEMPTY))
   (SETQ OUTPUTQNONEMPTY (CREATE.EVENT 'OUTPUTQNONEMPTY))
   (SETQ INPUTQ (CONS NIL NIL)) (* TCONC format *)
   (SETQ OUTPUTQ (CONS NIL NIL)) (* TCONC format *)
   (SETQ SEND.MORE.CHUCK.BERRY NIL)
   (ADD.PROCESS '(3TOP)
       'NAME '3TOP
       'RESTARTABLE 'HARDRESET
       'FORM '(RESTART.3TOP))))))

(DEFINEQ (3TOP (LAMBDA ()
    (SETQ TEDIT.DEFAULT.WINDOW NIL)
    (EMACS NIL NIL T '(EMACSTOPLEVEL T) T))))



(* GET.FROM.EMACS is used by the 3-LISP process to
   obtain input from the EMACS top level process (or
   perhaps one of the EMACS editor processes).  A
   special marker is also sent to the EMACS top level
   to indicate that it should not wait for further output
   from the 3-LISP process; rather, the 3-LISP process
   will start waiting for input. *)
 
(DEFINEQ (GET.FROM.EMACS (LAMBDA ()
    (PROG (EXP)
      (WITH.MONITOR INPUTQMONITOR
         (UNTIL (NOT (NULL (CAR INPUTQ))) DO
             (SETQ SEND.MORE.CHUCK.BERRY T) (* Says we're hung. *)
             (NOTIFY.EVENT OUTPUTQNONEMPTY)
             (MONITOR.AWAIT.EVENT INPUTQMONITOR INPUTQNONEMPTY)
             (SETQ SEND.MORE.CHUCK.BERRY NIL))
         (SETQ EXP (CAR (CAR INPUTQ))) 
         (RPLACA INPUTQ (CDR (CAR INPUTQ)))
         (IF (NULL (CAR INPUTQ)) THEN 
             (RPLACD INPUTQ NIL))) 
      (BLOCK)
      (RETURN EXP))))) 

(* SEND.TO.EMACS is used by the 3-LISP process to
   send print requests to the EMACS top level process. *)

(DEFINEQ (SEND.TO.EMACS (LAMBDA (KIND EXP)
    (PROG ()
      (WITH.MONITOR OUTPUTQMONITOR
         (TCONC OUTPUTQ (LIST KIND EXP))
         (NOTIFY.EVENT OUTPUTQNONEMPTY T))
      (BLOCK)))))


STOP