(* File: {PHYLUM}<DESRIVIERES>NLISP>SLURP *)

(* Last edited: Oct. 28, 1983 by Jim des Rivieres. *)

(DEFINEQ (U-CASE-ATOMS (LAMBDA (X)
  (PROG ()
   (IF (LITATOM X) THEN (RETURN (U-CASE X)))
   (IF (NLISTP X) THEN (RETURN X))
   (RETURN (FOR E IN X COLLECT (U-CASE-ATOMS E)))))))


(DEFINEQ (L-CASE-ATOMS (LAMBDA (X FLG)
  (PROG ()
   (IF (LITATOM X) THEN (RETURN (L-CASE X FLG)))
   (IF (NLISTP X) THEN (RETURN X))
   (RETURN (FOR E IN X COLLECT (L-CASE-ATOMS E FLG)))))))




(DEFINEQ (SLURP (LAMBDA (FILE READTABLE)
   (PROG (X EXP UEXP EXPR-LIST)
      (IF (NULL READTABLE) THEN
          (SETQ READTABLE T))
      (CLOSEF? FILE)
      (INFILE FILE)
      (SETQ X (CONS NIL NIL))
      (NLSETQ 
         (WHILE T DO
             (* Give someone else a chance. *)
             (BLOCK)
             (SETQ EXP (READ NIL T))
             (SETQ UEXP (U-CASE-ATOMS EXP))
             (COND ((NLISTP UEXP)
                    (PRINTOUT NIL "[" UEXP "] " T))
                   ((EQ (CAR UEXP) 'DEFUN)
                    (PRINTOUT NIL (CADR UEXP) ", "))
                   ((EQ (CAR UEXP) 'DEFINEQ)
                    (PRINTOUT NIL (CAADR UEXP) ", "))
                   ((EQ (CAR UEXP) 'SETQ)
                    (PRINTOUT NIL (CADR UEXP) ", "))
                   (T (PRINTOUT NIL "(" (CAR UEXP) ") ")))
             (TCONC X UEXP)))
      (PRINTOUT NIL T)
      (SETQ EXPR-LIST (CAR X))
      (RETURN EXPR-LIST))))) 

(DEFINEQ (INTERSLURP (LAMBDA (FILE)
  (RESETVAR FILEPKGFLG NIL
    (PROG (FORMS)
       (SETQ FORMS (SLURP FILE FILERDTBL))
       (FOR F IN FORMS DO
          (BLOCK)  (* Let some other process go ahead. *)
          (IF (NOT (EQUAL F 'STOP)) THEN
              (ERSETQ (EVAL F)))) )))))

(DEFINEQ (INTERCOMPL (LAMBDA (FILE)
  (RESETVAR FILEPKGFLG NIL
    (PROG (FORMS FNS-TO-COMPILE)
       (SETQ FORMS (SLURP FILE FILERDTBL))
       (SETQ FNS-TO-COMPILE (CONS NIL NIL))
       (FOR F IN FORMS DO
          (BLOCK)  (* Let some other process go ahead. *)
          (IF (NOT (EQUAL F 'STOP)) THEN
              (ERSETQ (EVAL F)))
          (COND ((NLISTP F) NIL)
                ((EQUAL (CAR F) 'DEFUN) 
                 (TCONC FNS-TO-COMPILE (CADR F)))
                ((EQUAL (CAR F) 'DEFINEQ) 
                 (TCONC FNS-TO-COMPILE (CAADR F)))))
       (SETQ FNS-TO-COMPILE (CAR FNS-TO-COMPILE))
       (FOR F IN FNS-TO-COMPILE DO
          (COMPILE! F T) 
          (REMPROP F 'EXPR)))))))
 

STOP