;;; -*- Mode:Common-Lisp; Package:UCL; Fonts:(CPTFONT HL10B HL12BI); Base:10; Patch-file:T -*-

Ï2;;;	UCL patches for SchemeÏ*

;; 12/05/87 D.N.G.

(Defun CHECK-TOP-LEVEL (expression &Optional replace?)
  "Ï2Test for typing errors in expression. Ï* Ï2Returns a string if an error is found, else NIL.Ï*  Ï2If
REPLACE? Ï* Ï2is not NIL then do RPLACA's on symbols in the wrong packageÏ*"
  (DECLARE (SPECIAL user:rh-error-search))
  (COND ((ATOM expression)
	 (WHEN (AND (SYMBOLP expression)
		    (With-Otl-And-Sg NIL (NOT (Boundp-Regardless expression))) ;Ï1Check for atoms boundÏ*
		    (not (and (sys:scheme-on-p) (fboundp expression)))
		    )
	   (LET ((new-atom (AND replace?
                                (With-Otl-And-Sg (*QUERY-IO*) (si:DWIMIFY-PACKAGE-0 expression 'Boundp-Regardless)))))
	     (IF new-atom
		 (VALUES NIL new-atom)
                 (PROGN (SETQ USER:RH-ERROR-SEARCH expression)
                        (FORMAT NIL "~S not bound at top level" expression))))))
	((AND (SYMBOLP (CAR expression)) (FBOUNDP (CAR expression)))    ;Ï1Check for Function boundÏ*
	 (Check-Function-Arglist expression replace?))
	Ï1;;Check for lambda expressions and substs, such as ((lambda (x) x) 43) or ((subst (x) x) 43).Ï*
	((AND (CONSP (CAR expression))
	      (OR (FUNCTIONP (CAR expression))
		  (AND (CONSP (CAR expression))
		       (SYMBOLP (CAAR expression))
		       (GET (CAAR expression) 'LAMBDA-MACRO))))
	 (Check-Function-Arglist expression replace?))
	((and (consp (car expression))
	      (sys:scheme-on-p))
	 (Check-Function-Arglist (cons 'funcall expression) replace?))
	Ï1;;Check for function in wrong packageÏ*
	(replace?
	 (LET ((new-function (SI:DWIMIFY-PACKAGE-0 (CAR expression) 'FDEFINEDP)))
	   (IF (NULL new-function)
               (PROGN
                 (SETQ USER:RH-ERROR-SEARCH (CAR expression))
                 (FORMAT NIL "~S is not a function" (CAR expression)))
               (PROGN
                 (RPLACA expression new-function)
                 (Check-Function-Arglist expression replace?)))))
	(T (SETQ USER:RH-ERROR-SEARCH (CAR expression))
	   (FORMAT NIL "~S is not a function" (CAR expression)))))
 

(Defmethod (Top-Level-Symbols :HANDLE-TYPEIN-P) (expression type)
  (WHEN (NOT (MEMBER type '(CONS :IMPLICIT-LIST) :Test #'EQUAL))
    ;Ï1;Ï* Ï1Kludge.  The other modes sometimes take an atom and change it to a list to simplify things.Ï*
    (WHEN (CONSP expression)
      (SETQ expression (CAR expression)))
    (MULTIPLE-VALUE-BIND (error new-value)
	(Check-Top-Level expression Dwimify-Package-P)
      (WHEN new-value (SETQ - new-value
			    expression new-value))
      Ï1;;Ï* Ï1ThÏ*is Ï1NOT doesn't work inside the with-otl.  Why?Ï*
      (VALUES (UNLESS (AND (SYMBOLP expression)
			   (NOT (With-Otl-And-sg NIL (Boundp-Regardless expression)))
			   (not (and (sys:scheme-on-p) (fboundp expression))))
		SELF)
	      error))))