Undefined functions and style-warnings
- Subject: Undefined functions and style-warnings
- From: Andreas Eder
- Date: Mon, 10 May 2004 23:45:01 +0200
Hi, here I am again with a few correctiosn to some files.
In nusum.lisp and trans1.lisp I noticed a function that was used tough
undefined *merror. I changed that to use merror and in the process
cleaned up both files a bit and especially merror.lisp, where there
was lots of code for pdp10 and lisp machines (all flavours) that I
commented out to make the warking code stand out better.
All lisps (sbcl, cmucl,, clisp and gcl) compiled without problems from
make clean. There were no unexpected problems in make check.
So here are the diffs:
diff -u nusum.lisp.old nusum.lisp.new
--- nusum.lisp.old 2003-03-11 05:24:37.000000000 +0100
+++ nusum.lisp.new 2004-05-10 22:21:57.000000000 +0200
@@ -2,8 +2,8 @@
;;;Translated on: 4/21/85 11:00:16
(in-package "MAXIMA")
-(EVAL-WHEN (COMPILE EVAL LOAD)
- (EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
+ (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $DVA T TRANSLATED)
(ADD2LNC '$DVA $PROPS)
(DEFMTRFUN ($DVA $ANY MDEFMACRO NIL NIL)
@@ -12,47 +12,47 @@
(MBUILDQ-SUBST (LIST (CONS '$VAR $VAR))
'(($DEFINE_VARIABLE) $VAR
((MQUOTE) $VAR) $ANY)))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%N $ANY))
(MEVAL* '(($DECLARE) $%N $SPECIAL))
NIL
(DEF-MTRVAR $%N '$%N))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%PW $ANY))
(MEVAL* '(($DECLARE) $%PW $SPECIAL))
NIL
(DEF-MTRVAR $%PW '$%PW))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%F $ANY))
(MEVAL* '(($DECLARE) $%F $SPECIAL))
NIL
(DEF-MTRVAR $%F '$%F))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%F1 $ANY))
(MEVAL* '(($DECLARE) $%F1 $SPECIAL))
NIL
(DEF-MTRVAR $%F1 '$%F1))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $L% $ANY))
(MEVAL* '(($DECLARE) $L% $SPECIAL))
NIL
(DEF-MTRVAR $L% '$L%))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $SOLVEP $ANY))
(MEVAL* '(($DECLARE) $SOLVEP $SPECIAL))
NIL
(DEF-MTRVAR $SOLVEP '$SOLVEP))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%R $ANY))
(MEVAL* '(($DECLARE) $%R $SPECIAL))
NIL
(DEF-MTRVAR $%R '$%R))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $P $ANY))
(MEVAL* '(($DECLARE) $P $SPECIAL))
NIL
(DEF-MTRVAR $P '$P))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(MEVAL* '(($MODEDECLARE) $%CF $ANY))
(MEVAL* '(($DECLARE) $%CF $SPECIAL))
NIL
@@ -61,7 +61,7 @@
;$%2 $n $%n $%pw $p $%g ;thing the problem was errset.
))
)
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $ALGEBRAICP T TRANSLATED)
(ADD2LNC '$ALGEBRAICP $PROPS)
(DEFMTRFUN
@@ -91,14 +91,14 @@
((LAMBDA (X)
(COND ((NULL MCATCH)
(DISPLA X)
- (*MERROR '|THROW not within CATCH|)))
+ (MERROR "THROW not within CATCH")))
(THROW 'MCATCH X))
T))))))
$%1))
NIL))
(ERRLFUN1 MCATCH)))
(CONS BINDLIST LOCLIST))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $HICOEF T TRANSLATED)
(ADD2LNC '$HICOEF $PROPS)
(DEFMTRFUN ($HICOEF $ANY MDEFINE NIL NIL)
@@ -106,7 +106,7 @@
NIL
(PROGN (SETQ $X (SIMPLIFY ($RATSIMP $X $N)))
(SIMPLIFY ($COEFF $X $N (SIMPLIFY ($HIPOW $X $N)))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $GENPOL T TRANSLATED)
(ADD2LNC '$GENPOL $PROPS)
(DEFMTRFUN ($GENPOL $ANY MDEFINE NIL NIL)
@@ -116,7 +116,7 @@
(T (ADD* (SIMPLIFY ($CONCAT '$% $N))
(MUL* (TRD-MSYMEVAL $%N '$%N)
(SIMPLIFY ($GENPOL (ADD* $N -1)))))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $CLIST T TRANSLATED)
(ADD2LNC '$CLIST $PROPS)
(DEFMTRFUN
@@ -135,7 +135,7 @@
(*MMINUS (TRD-MSYMEVAL $%PW
'$%PW)))
(TRD-MSYMEVAL $%N '$%N))))))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $UNSUM T TRANSLATED)
(ADD2LNC '$UNSUM $PROPS)
(DEFMTRFUN
@@ -177,7 +177,7 @@
(SIMPLIFY ($UNSUM $X
(TRD-MSYMEVAL $%N '$%N)))))
$%G))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $PRODFLIP T TRANSLATED)
(ADD2LNC '$PRODFLIP $PROPS)
(DEFMTRFUN
@@ -200,7 +200,7 @@
(TRD-MSYMEVAL $% '$%)
(TRD-MSYMEVAL $%% '$%%))))))))
$%0))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $PRODGUNCH T TRANSLATED)
(ADD2LNC '$PRODGUNCH $PROPS)
(DEFMTRFUN
@@ -407,7 +407,7 @@
$%0))
(*MMINUS $%0)))))))))
$%0))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $PRODU T TRANSLATED)
(ADD2LNC '$PRODU $PROPS)
(DEFMTRFUN
@@ -442,26 +442,26 @@
$X)))
1
(SIMPLIFY ($RATSIMP (ADD* $%3 (*MMINUS (TRD-MSYMEVAL $% '$%))))))))
-#+nil
-(EVAL-WHEN (COMPILE EVAL LOAD)
- (DEFPROP $NUSUM T TRANSLATED)
- (ADD2LNC '$NUSUM $PROPS)
- (DEFMTRFUN ($NUSUM NIL MDEFINE NIL NIL)
- ($%A $%N $%L $%H)
- NIL
- ((LAMBDA ($MAPPRINT $PROGRAMMODE $SOLVENULLWARN)
- NIL
- (MAREF 'MQAPPLY
- (SIMPLIFY ($NUSUML $%A
- (TRD-MSYMEVAL $%N '$%N)
- $%L
- $%H
- '((MLIST))))
- 1))
- NIL
- T
- NIL)))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+;#+nil
+;(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
+; (DEFPROP $NUSUM T TRANSLATED)
+; (ADD2LNC '$NUSUM $PROPS)
+; (DEFMTRFUN ($NUSUM NIL MDEFINE NIL NIL)
+; ($%A $%N $%L $%H)
+; NIL
+; ((LAMBDA ($MAPPRINT $PROGRAMMODE $SOLVENULLWARN)
+; NIL
+; (MAREF 'MQAPPLY
+; (SIMPLIFY ($NUSUML $%A
+; (TRD-MSYMEVAL $%N '$%N)
+; $%L
+; $%H
+; '((MLIST))))
+; 1))
+; NIL
+; T
+; NIL)))
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $NUSUM T TRANSLATED)
(ADD2LNC '$NUSUM $PROPS)
(DEFMTRFUN ($NUSUM $ANY MDEFINE NIL NIL)
@@ -478,7 +478,7 @@
NIL
T
NIL)))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $FUNCSOLVE T TRANSLATED)
(ADD2LNC '$FUNCSOLVE $PROPS)
(DEFMTRFUN ($FUNCSOLVE NIL MDEFINE NIL NIL)
@@ -494,7 +494,7 @@
NIL
T
NIL)))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $DIMSUM T TRANSLATED)
(ADD2LNC '$DIMSUM $PROPS)
(DEFMTRFUN
@@ -621,7 +621,7 @@
'$%CD
'$%PT
'$%PW)))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $RATSOLVE T TRANSLATED)
(ADD2LNC '$RATSOLVE $PROPS)
(DEFMTRFUN
@@ -646,7 +646,7 @@
$X)))
(T '((MLIST)))))
(MUL* 2 (POWER (SIMPLIFY ($FACTOR (TRD-MSYMEVAL $P '$P))) 2)))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $PRODSHIFT T TRANSLATED)
(ADD2LNC '$PRODSHIFT $PROPS)
(DEFMTRFUN
@@ -673,7 +673,7 @@
(ADD* (TRD-MSYMEVAL $% '$%) $%2)
(ADD* $%3 $%2)))))))
$%0))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $RFORN T TRANSLATED)
(ADD2LNC '$RFORN $PROPS)
(DEFMTRFUN
@@ -717,7 +717,7 @@
(MAREF (TRD-MSYMEVAL $%R '$%R)
1)))))
T)))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $RFORM T TRANSLATED)
(ADD2LNC '$RFORM $PROPS)
(DEFMTRFUN
@@ -767,7 +767,7 @@
(T (SIMPLIFY ($ERROR (DIV (MAREF (TRD-MSYMEVAL $%R '$%R) 1)
(MAREF (TRD-MSYMEVAL $%R '$%R) 2))
'|&NON-RATIONAL TERM RATIO TO NUSUM|))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $NUSUML T TRANSLATED)
(ADD2LNC '$NUSUML $PROPS)
(DEFMTRFUN
@@ -989,7 +989,7 @@
(SIMPLIFY ($FUNMAKE '$%F (LIST '(MLIST) (TRD-MSYMEVAL $%N '$%N))))
(SIMPLIFY ($FUNMAKE '$%F
(LIST '(MLIST) (ADD* (TRD-MSYMEVAL $%N '$%N) 1)))))))))
-(EVAL-WHEN (COMPILE EVAL LOAD)
+(EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE :LOAD-TOPLEVEL)
(DEFPROP $FUNCSOL T TRANSLATED)
(ADD2LNC '$FUNCSOL $PROPS)
(DEFMTRFUN
@@ -1097,4 +1097,4 @@
'$%F1
'$%CL
'$%CM
- (SIMPLIFY ($INPART (TRD-MSYMEVAL $%F '$%F) 1)))))
\ No newline at end of file
+ (SIMPLIFY ($INPART (TRD-MSYMEVAL $%F '$%F) 1)))))
diff -u trans1.lisp.old trans1.lisp.new
--- trans1.lisp.old 2002-07-02 23:13:15.000000000 +0200
+++ trans1.lisp.new 2004-05-10 22:11:35.000000000 +0200
@@ -30,36 +30,36 @@
;;; The second arg to MMAPEV is purely for printing of error messages
;;; except for SCANMAP, which is obscure.
-(comment
+;(comment
-(DEFMFUN MMAPEV (MAPFUN L)
- (IF (< (LENGTH L) 2)
- (MERROR "~:M called with fewer than 2 args" MAPFUN))
- (LET ((U (GETOPR (MEVAL (CAR L)))))
- (AUTOLDCHK U)
- (BADFUNCHK (CAR L) U NIL)
- (IF (ATOM U)
- ;; number of argument checking before mapping,
- ;; some efficiency gain, really, how minor.
- ;; he should instead do some trampolining and
- ;; get some real efficiency gains.
- (MARGCHK U (COND ((EQ MAPFUN '$SCANMAP)
- (NCONS (CADR L)))
- (T (CDR L)))))
- (CONS U (MAPCAR 'MEVAL (CDR L)))))
-)
-
-(comment
- (DEFMFUN $APPLY FEXPR (L)
- (TWO-ARG-CHECK L)
- ((LAMBDA (FUN ARG)
- (COND ((NOT ($LISTP ARG))
- (DISPLA FUN) (DISPLA ARG) (MERROR "Second arg to APPLY must be a list")))
- (AUTOLDCHK (SETQ FUN (GETOPR FUN)))
- (COND ((EQ (GET FUN 'DIMENSION) 'DIMENSION-INFIX) (TWOARGCHK ARG FUN)))
- (MAPPLY FUN (CDR ARG) (CAR L)))
- (MEVAL (CAR L)) (MEVAL (CADR L))))
-)
+;(DEFMFUN MMAPEV (MAPFUN L)
+; (IF (< (LENGTH L) 2)
+; (MERROR "~:M called with fewer than 2 args" MAPFUN))
+; (LET ((U (GETOPR (MEVAL (CAR L)))))
+; (AUTOLDCHK U)
+; (BADFUNCHK (CAR L) U NIL)
+; (IF (ATOM U)
+; ;; number of argument checking before mapping,
+; ;; some efficiency gain, really, how minor.
+; ;; he should instead do some trampolining and
+; ;; get some real efficiency gains.
+; (MARGCHK U (COND ((EQ MAPFUN '$SCANMAP)
+; (NCONS (CADR L)))
+; (T (CDR L)))))
+; (CONS U (MAPCAR 'MEVAL (CDR L)))))
+;)
+
+;(comment
+; (DEFMFUN $APPLY FEXPR (L)
+; (TWO-ARG-CHECK L)
+; ((LAMBDA (FUN ARG)
+; (COND ((NOT ($LISTP ARG))
+; (DISPLA FUN) (DISPLA ARG) (MERROR "Second arg to APPLY must be a list")))
+; (AUTOLDCHK (SETQ FUN (GETOPR FUN)))
+; (COND ((EQ (GET FUN 'DIMENSION) 'DIMENSION-INFIX) (TWOARGCHK ARG FUN)))
+; (MAPPLY FUN (CDR ARG) (CAR L)))
+; (MEVAL (CAR L)) (MEVAL (CADR L))))
+;)
;;; APPLY(F,[X]) is an idiom for funcall.
@@ -231,17 +231,16 @@
-
;;; From JPG;SUPRV >
-(comment
-(DEFMFUN $ERRCATCH FEXPR (X)
- ((LAMBDA (ERRCATCH RET)
- (COND ((NULL (SETQ RET
- (ERRSET (APPLY 'MPROGN X)
- LISPERRPRINT)))
- (ERRLFUN1 ERRCATCH)))
- (CONS '(MLIST) RET))
- (CONS BINDLIST LOCLIST) NIL)))
+;(comment
+;(DEFMFUN $ERRCATCH FEXPR (X)
+; ((LAMBDA (ERRCATCH RET)
+; (COND ((NULL (SETQ RET
+; (ERRSET (APPLY 'MPROGN X)
+; LISPERRPRINT)))
+; (ERRLFUN1 ERRCATCH)))
+; (CONS '(MLIST) RET))
+; (CONS BINDLIST LOCLIST) NIL)))
;;; This is could be done better on the LISPM
@@ -256,12 +255,12 @@
(CONS BINDLIST LOCLIST) NIL)))
-(COMMENT
- (DEFMFUN $CATCH FEXPR (X)
- ((LAMBDA (MCATCH)
- (PROG2 NIL (CATCH 'MCATCH (APPLY 'MPROGN X))
- (ERRLFUN1 MCATCH)))
- (CONS BINDLIST LOCLIST))))
+;(COMMENT
+; (DEFMFUN $CATCH FEXPR (X)
+; ((LAMBDA (MCATCH)
+; (PROG2 NIL (CATCH 'MCATCH (APPLY 'MPROGN X))
+; (ERRLFUN1 MCATCH)))
+; (CONS BINDLIST LOCLIST))))
;;; The MODE of a CATCH could either be the MODE of the last of the PROGN
;;; or the mode of the THROW. The THROW may be hard to find, so this goes
@@ -276,33 +275,33 @@
'MCATCH ,BODY)
(ERRLFUN1 MCATCH)))
(CONS BINDLIST LOCLIST)))))))
-(COMMENT
- (DEFMFUN $THROW (X)
- (COND ((NULL MCATCH) (DISPLA X) (ERLIST '|THROW not within CATCH|)))
- (THROW 'MCATCH X)))
+;(COMMENT
+; (DEFMFUN $THROW (X)
+; (COND ((NULL MCATCH) (DISPLA X) (ERLIST '|THROW not within CATCH|)))
+; (THROW 'MCATCH X)))
(DEF%TR $THROW (FORM)
(LET (((MODE . EXP) (TRANSLATE (CADR FORM))))
`(,MODE . ((LAMBDA (X)
(COND ((NULL MCATCH)
(DISPLA X)
- (*MERROR '|THROW not within CATCH|)))
+ (MERROR "THROW not within CATCH")))
(THROW 'MCATCH X))
,EXP))))
;;; From RZ;ASUM >. He should know better.
-(comment
- (DEFMFUN $sum fexpr (l)
- (cond ((not (= (length l) 4))
- (erlist '|Wrong no. of args to SUM|))
- ((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
- ))))
+;(comment
+; (DEFMFUN $sum fexpr (l)
+; (cond ((not (= (length l) 4))
+; (erlist '|Wrong no. of args to SUM|))
+; ((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
+; ))))
;;; From RZ;COMBIN >
-(comment
- (DEFMFUN $product fexpr (l)
- (cond ((not (= (length l) 4)) (erlist '|Wrong no. of args to product|))
- ((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) nil)))))
+;(comment
+; (DEFMFUN $product fexpr (l)
+; (cond ((not (= (length l) 4)) (erlist '|Wrong no. of args to product|))
+; ((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) nil)))))
;;; "dosum" will call MEVAL and act like a special form if it can.
;;; MEVAL will work on LISP expression, so we can translate those args.
@@ -443,9 +442,9 @@
(SETQ TR-ABORT T)
'($ANY . '$**ERROR**))))
-(comment
- |jpg;suprv >|
- (DEFMFUN $KILL FEXPR (L) (MAPC 'KILL1 L) #+GC (GCTWA) '$DONE))
+;(comment
+; |jpg;suprv >|
+; (DEFMFUN $KILL FEXPR (L) (MAPC 'KILL1 L) #+GC (GCTWA) '$DONE))
(DEF%TR $KILL (FORM)
(COND ($TR_WINDY
@@ -480,12 +479,12 @@
,@(TR-ARGS (CDR FORM)))))))))
-(comment
-(DEFMFUN $DEFINE FEXPR (L)
- (COND ((OR (NULL L) (NULL (CDR L)) (CDDR L))
- (ERLIST '|Wrong number of args to DEFINE|)))
- (APPLY 'MDEFINE
- (LIST (COND ((MQUOTEP (CAR L)) (CADAR L)) (T (DISP2 (CAR L)))) (MEVAL (CADR L))))))
+;(comment
+;(DEFMFUN $DEFINE FEXPR (L)
+; (COND ((OR (NULL L) (NULL (CDR L)) (CDDR L))
+; (ERLIST '|Wrong number of args to DEFINE|)))
+; (APPLY 'MDEFINE
+; (LIST (COND ((MQUOTEP (CAR L)) (CADAR L)) (T (DISP2 (CAR L)))) (MEVAL (CADR L))))))
;;; MDEFINE is an FSUBR also.
@@ -587,7 +586,6 @@
(DEF%TR $SETUP_AUTOLOAD $batcon)
(DEF%TR $TOBREAK $batcon )
-
;; Local Modes:
;; Mode: LISP
;; Comment Col: 40
diff -u merror.lisp.old merror.lisp.new
--- merror.lisp.old 2003-12-07 00:16:03.000000000 +0100
+++ merror.lisp.new 2004-05-10 21:07:54.000000000 +0200
@@ -16,7 +16,7 @@
;;; Macsyma error signalling.
;;; 2:08pm Tuesday, 30 June 1981 George Carrette.
-(defvar DEBUG T "Enter the lisp on an error debugger if this is true")
+(defvar DEBUG T "Enter the lisp debugger on an error if this is true")
(DEFMVAR $ERROR '((MLIST SIMP) |&No error.|)
"During an MAXIMA-ERROR break this is bound to a list
@@ -45,7 +45,7 @@
(N 1 (f1+ (f+ N (ERROR-SIZE (CAR L))))))
((OR (atom L)
;; no need to go any further, and this will save us
- ;; from circular structures. (Which they display
+ ;; from circular structures. (Which the display
;; package would have a hell of a time with too.)
(> N $ERROR_SIZE))
N)
@@ -77,45 +77,41 @@
; (MAXIMA-ERROR #+(OR CL NIL) STRING))
-#+(and cl (not lispm))
+;#+(and cl (not lispm))
(DEFUN MERROR (SSTRING &REST L)
- (declare (special state-pdl errcatch debug))
- (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
- (AND $ERRORMSG ($ERRORMSG))
- (cond (debug
- (let ((dispflag t) ret)
- (declare (special $help dispflag))
- (format t " -- an error. Entering the Maxima Debugger dbm")
- (progn
- (setq ret ;;;(errbreak nil)
- (break-dbm-loop nil)
- )
- (cond ((eql ret :resume)
- (break-quit)))
+ (declare (special state-pdl errcatch debug))
+ (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
+ (AND $ERRORMSG ($ERRORMSG))
+ (cond (debug
+ (let ((dispflag t) ret)
+ (declare (special $help dispflag))
+ (format t " -- an error. Entering the Maxima Debugger dbm")
+ (progn
+ (setq ret (break-dbm-loop nil))
+ (cond ((eql ret :resume)
+ (break-quit)))
- #+previous
- (cond ((and (eql ret 'exit)
- (member 'macsyma-break state-pdl))
- (throw 'macsyma-break t))
- (t (throw 'macsyma-quit t)
- )))
-
-
-
- )
- )
- (errcatch (error " -- an error: macsyma error"))
- (t
- (fresh-line *standard-output*)
- ($backtrace 3)
- (format t "~& -- an error. Quitting. To debug this try DEBUGMODE(TRUE);)~%")
- (throw 'macsyma-quit t )
- ;(if errcatch (error "macsyma error"))
- )))
+;#+previous
+; (cond ((and (eql ret 'exit)
+; (member 'macsyma-break state-pdl))
+; (throw 'macsyma-break t))
+; (t (throw 'macsyma-quit t)
+; ))
+ )
+ )
+ )
+ (errcatch (error " -- an error: macsyma error"))
+ (t
+ (fresh-line *standard-output*)
+ ($backtrace 3)
+ (format t "~& -- an error. Quitting. To debug this try DEBUGMODE(TRUE);)~%")
+ (throw 'macsyma-quit t )
+ ;(if errcatch (error "macsyma error"))
+ )))
-#+(or CL NIL)
+;;;#+(or CL NIL)
;;; for debugging. Therefore they need to have the error variables
;;; SET (as the old ERREXP was), and not PROGV bound. The problem with
;;; this is that recursive errors will bash the old value of the error
@@ -124,87 +120,85 @@
;; Define the MACSYMA-ERROR condition.
-#+lispm
-(eval-when (compile load)
-(DEFFLAVOR MACSYMA-ERROR (MFORMAT-STRING #-ti(format-args nil)) (global:ERROR)
- :INITABLE-INSTANCE-VARIABLES
- :gettable-instance-variables)
-(DEFFLAVOR MACSYMA-DEBUGGER (MFORMAT-STRING) (global:ERROR)
- :INITABLE-INSTANCE-VARIABLES)
-
-)
+;#+lispm
+;(eval-when (compile load)
+; (DEFFLAVOR MACSYMA-ERROR (MFORMAT-STRING #-ti(format-args nil)) (global:ERROR)
+; :INITABLE-INSTANCE-VARIABLES
+; :gettable-instance-variables)
+; (DEFFLAVOR MACSYMA-DEBUGGER (MFORMAT-STRING) (global:ERROR)
+; :INITABLE-INSTANCE-VARIABLES)
+;)
;sample:
;(defun h (he)
; (merror "hi there ~:M and ~:M" he he))
-#+lispm
-(progn
-(DEFMETHOD (MACSYMA-ERROR :REPORT) (STREAM)
- (apply 'format stream mformat-string #-ti format-args #+ti eh:format-args))
-
-
-
-(COMPILE-FLAVOR-METHODS MACSYMA-ERROR)
+;#+lispm
+;(progn
+; (DEFMETHOD (MACSYMA-ERROR :REPORT) (STREAM)
+; (apply 'format stream mformat-string #-ti format-args #+ti eh:format-args))
-;;; I'm not sure that this is the right way to do this. We can always flush this when
-;;; enter-macsyma-debugger does the right thing.
+; (COMPILE-FLAVOR-METHODS MACSYMA-ERROR)
-(DEFMETHOD (MACSYMA-DEBUGGER :REPORT) (STREAM)
- stream ;ignore
-; (aformat STREAM MFORMAT-STRING)
- )
+;;;; I'm not sure that this is the right way to do this. We can always flush this when
+;;;; enter-macsyma-debugger does the right thing.
+
+
+
+; (DEFMETHOD (MACSYMA-DEBUGGER :REPORT) (STREAM)
+; stream ;ignore
+;; (aformat STREAM MFORMAT-STRING)
+; )
-;;Don't want to call the following since it will then the function displayed
-(DEFUN ENTER-MACSYMA-DEBUGGER ()
- (signal 'MACSYMA-DEBUGGER ':MFORMAT-STRING "Entering Lisp Debugger")
+; ;;Don't want to call the following since it will then the function displayed
+; (DEFUN ENTER-MACSYMA-DEBUGGER ()
+; (signal 'MACSYMA-DEBUGGER ':MFORMAT-STRING "Entering Lisp Debugger")
+; )
- )
+;(DEFPROP MERROR T :ERROR-REPORTER)
-(DEFPROP MERROR T :ERROR-REPORTER)
+;(DEFPROP enter-macsyma-debugger T :ERROR-REPORTER)
+;)
-(DEFPROP enter-macsyma-debugger T :ERROR-REPORTER)
-)
-
-#+ti
-(DEFMFUN MERROR (SSTRING &REST L)
- (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
- (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
- (AND $ERRORMSG ($ERRORMSG))
- (IF DEBUG
- (ENTER-MACSYMA-DEBUGGER)
-; (signal 'MACSYMA-ERROR ':MFORMAT-STRING
-; sstring ;(zl:format nil SsTRING)
-; :format-args (copy-rest-arg l))
- ;;the following should work..but int rel1.0
- ;(signal 'macsyma-error :mformat-string SsTRING :format-args l )
- (signal-condition (make-condition 'macsyma-error :mformat-string SsTRING :format-args l ))))
+;#+ti
+;(DEFMFUN MERROR (SSTRING &REST L)
+; (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
+; (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
+; (AND $ERRORMSG ($ERRORMSG))
+; (IF DEBUG
+; (ENTER-MACSYMA-DEBUGGER)
+;; (signal 'MACSYMA-ERROR ':MFORMAT-STRING
+;; sstring ;(zl:format nil SsTRING)
+;; :format-args (copy-rest-arg l))
+; ;;the following should work..but int rel1.0
+; ;;(signal 'macsyma-error :mformat-string SsTRING :format-args l )
+; (signal-condition (make-condition 'macsyma-error :mformat-string SsTRING :format-args l ))))
-#+(and LISPM (not ti))
-(DEFMFUN MERROR (SSTRING &REST L)
- (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
- (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
- (AND $ERRORMSG ($ERRORMSG))
- #+LISPM (IF DEBUG
- (ENTER-MACSYMA-DEBUGGER)
- (signal 'MACSYMA-ERROR ':MFORMAT-STRING
- #+(and cl symbolics)
- sstring ;(zl:format nil SsTRING)
- #-(or cl symbolics) sstring
- :format-args (copy-rest-arg l)
- )
- )
- #+lispm
- (signal 'macsyma-error :mformat-string SsTRING :format-args l )
- #+ nil (maxima-error sstring)
- #-(OR LISPM NIL) (MAXIMA-ERROR))
+;#+(and LISPM (not ti))
+;(DEFMFUN MERROR (SSTRING &REST L)
+; (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
+; (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
+; (AND $ERRORMSG ($ERRORMSG))
+; #+LISPM (IF DEBUG
+; (ENTER-MACSYMA-DEBUGGER)
+; (signal 'MACSYMA-ERROR ':MFORMAT-STRING
+; #+(and cl symbolics)
+; sstring ;(zl:format nil SsTRING)
+; #-(or cl symbolics) sstring
+; :format-args (copy-rest-arg l)
+; )
+; )
+; #+lispm
+; (signal 'macsyma-error :mformat-string SsTRING :format-args l )
+; #+ nil (maxima-error sstring)
+; #-(OR LISPM NIL) (MAXIMA-ERROR))
(DEFMVAR $ERROR_SYMS '((MLIST) $ERREXP1 $ERREXP2 $ERREXP3)
"Symbols to bind the too-large MAXIMA-ERROR expresssions to")
@@ -270,7 +264,6 @@
(DEFPROP $ERROR READ-ONLY-ASSIGN ASSIGN)
-
;; THIS THROWS TO (CATCH 'RATERR ...), WHEN A PROGRAM ANTICIPATES
;; AN ERROR (E.G. ZERO-DIVIDE) BY SETTING UP A CATCH AND SETTING
@@ -296,8 +289,7 @@
(se nil))
((null l)
(setq sl (maknam sl))
- #+PDP10
- (putprop sl t '+INTERNAL-STRING-MARKER)
+ ;#+PDP10 (putprop sl t '+INTERNAL-STRING-MARKER)
(cons sl (nreverse se)))
(setq s (pop l))
(cond ((and (symbolp s) (char= (getcharn s 1) #\&))
@@ -310,99 +302,96 @@
(push s se)
(setq sb (list #\~ #\M))))
(setq sl (nconc sl sb (if (null l) nil (list #\SPACE))))))
-
-
-#+PDP10
-(PROGN 'COMPILE
- ;; Fun and games with the pdp-10. The calling sequence for
- ;; subr, (arguments passed through registers), is much smaller
- ;; than that for lsubrs. If we really where going to do a lot
- ;; of this hackery then we would define some kind of macro
- ;; for it.
- (LET ((X (GETL 'MERROR '(EXPR LSUBR))))
- (REMPROP '*MERROR (CAR X))
- (PUTPROP '*MERROR (CADR X) (CAR X)))
- (DECLARE (*LEXPR *MERROR))
- (DEFMFUN *MERROR-1 (A) (*MERROR A))
- (DEFMFUN *MERROR-2 (A B) (*MERROR A B))
- (DEFMFUN *MERROR-3 (A B C) (*MERROR A B C))
- (DEFMFUN *MERROR-4 (A B C D) (*MERROR A B C D))
- (DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E))
-
-
- (LET ((X (GETL 'ERRRJF '(EXPR LSUBR))))
- (REMPROP '*ERRRJF (CAR X))
- (PUTPROP '*ERRRJF (CADR X) (CAR X)))
- (DECLARE (*LEXPR *ERRRJF))
- (DEFMFUN *ERRRJF-1 (A) (*ERRRJF A))
-
- )
-#+Maclisp
-(progn 'compile
-(defun m-wna-eh (((f . actual-args) args-info))
- ;; generate a nice user-readable message about this lisp error.
- ;; F may be a symbol or a lambda expression.
- ;; args-info may be nil, an args-info form, or a formal argument list.
- (merror "~M ~A to function ~A"
- `((mlist) ,@actual-args)
- ;; get the error messages passed as first arg to lisp ERROR.
- (caaddr (errframe ()))
- (if (symbolp f)
- (if (or (equal (args f) args-info)
- (symbolp args-info))
- f
- `((,f),@args-info))
- `((lambda)((mlist),@(cadr f))))))
-
-(defun m-wta-eh ((object))
- (merror "~A: ~A" (caaddr (errframe ())) object))
-
-(defun m-ubv-eh ((variable))
- (merror "Unbound variable: ~A" variable))
-
-;; TRANSL generates regular LISP function calls for functions which
-;; are lisp defined at translation time, and in compiled code.
-;; MEXPRs can be handled by the UUF (Undefined User Function) handler.
-
-(DEFVAR UUF-FEXPR-ALIST ())
-#+lispm
-(DEFPROP ENTER-MACSYMA-DEBUGGER T :ERROR-REPORTER)
-
-(DEFUN UUF-HANDLER (X)
- (LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO))
- (GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))))
- (CASE (CAR FUNP)
- ((MEXPR)
- ;; The return value of the UUF-HANDLER is put back into
- ;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated,
- ;; checked for "functionality" and applied if a function,
- ;; otherwise it is evaluated again, unless it's atomic,
- ;; in which case it will call the UNDF-FNCTN handler again,
- ;; unless (STATUS PUNT) is NIL in which case it is
- ;; evaluated (I think). One might honestly ask
- ;; why the maclisp evaluator behaves like this. -GJC
- `((QUOTE (LAMBDA *N*
- (MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X) (LISTIFY *N*))))))
- ((MMACRO TRANSLATED-MMACRO)
- (MERROR
- "Call to a macro '~:@M' which was undefined during translation."
- (CAR X)))
- ((MFEXPR* MFEXPR*S)
- ;; An call in old translated code to what was a FEXPR.
- (LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST)))
- (OR CELL
- (LET ((NAME (GENSYM)))
- (PUTPROP NAME
- `(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME)))
- 'FEXPR)
- (SETQ CELL (LIST (CAR X) NAME))
- (PUSH CELL UUF-FEXPR-ALIST)))
- (CDR CELL)))
- (T
- (MERROR "Call to an undefined function '~A' at Lisp level."
- (CAR X))))))
-)
-nil
+;#+PDP10
+;(PROGN 'COMPILE
+; ;; Fun and games with the pdp-10. The calling sequence for
+; ;; subr, (arguments passed through registers), is much smaller
+; ;; than that for lsubrs. If we really where going to do a lot
+; ;; of this hackery then we would define some kind of macro
+; ;; for it.
+; (LET ((X (GETL 'MERROR '(EXPR LSUBR))))
+; (REMPROP '*MERROR (CAR X))
+; (PUTPROP '*MERROR (CADR X) (CAR X)))
+; (DECLARE (*LEXPR *MERROR))
+; (DEFMFUN *MERROR-1 (A) (*MERROR A))
+; (DEFMFUN *MERROR-2 (A B) (*MERROR A B))
+; (DEFMFUN *MERROR-3 (A B C) (*MERROR A B C))
+; (DEFMFUN *MERROR-4 (A B C D) (*MERROR A B C D))
+; (DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E))
+
+
+; (LET ((X (GETL 'ERRRJF '(EXPR LSUBR))))
+; (REMPROP '*ERRRJF (CAR X))
+; (PUTPROP '*ERRRJF (CADR X) (CAR X)))
+; (DECLARE (*LEXPR *ERRRJF))
+; (DEFMFUN *ERRRJF-1 (A) (*ERRRJF A))
+
+; )
+;#+Maclisp
+;(progn 'compile
+;(defun m-wna-eh (((f . actual-args) args-info))
+; ;; generate a nice user-readable message about this lisp error.
+; ;; F may be a symbol or a lambda expression.
+; ;; args-info may be nil, an args-info form, or a formal argument list.
+; (merror "~M ~A to function ~A"
+; `((mlist) ,@actual-args)
+; ;; get the error messages passed as first arg to lisp ERROR.
+; (caaddr (errframe ()))
+; (if (symbolp f)
+; (if (or (equal (args f) args-info)
+; (symbolp args-info))
+; f
+; `((,f),@args-info))
+; `((lambda)((mlist),@(cadr f))))))
+
+;(defun m-wta-eh ((object))
+; (merror "~A: ~A" (caaddr (errframe ())) object))
+
+;(defun m-ubv-eh ((variable))
+; (merror "Unbound variable: ~A" variable))
+
+;;; TRANSL generates regular LISP function calls for functions which
+;;; are lisp defined at translation time, and in compiled code.
+;;; MEXPRs can be handled by the UUF (Undefined User Function) handler.
+
+;(DEFVAR UUF-FEXPR-ALIST ())
+;#+lispm
+;(DEFPROP ENTER-MACSYMA-DEBUGGER T :ERROR-REPORTER)
+
+;(DEFUN UUF-HANDLER (X)
+; (LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO))
+; (GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))))
+; (CASE (CAR FUNP)
+; ((MEXPR)
+; ;; The return value of the UUF-HANDLER is put back into
+; ;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated,
+; ;; checked for "functionality" and applied if a function,
+; ;; otherwise it is evaluated again, unless it's atomic,
+; ;; in which case it will call the UNDF-FNCTN handler again,
+; ;; unless (STATUS PUNT) is NIL in which case it is
+; ;; evaluated (I think). One might honestly ask
+; ;; why the maclisp evaluator behaves like this. -GJC
+; `((QUOTE (LAMBDA *N*
+; (MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X) (LISTIFY *N*))))))
+; ((MMACRO TRANSLATED-MMACRO)
+; (MERROR
+; "Call to a macro '~:@M' which was undefined during translation."
+; (CAR X)))
+; ((MFEXPR* MFEXPR*S)
+; ;; An call in old translated code to what was a FEXPR.
+; (LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST)))
+; (OR CELL
+; (LET ((NAME (GENSYM)))
+; (PUTPROP NAME
+; `(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME)))
+; 'FEXPR)
+; (SETQ CELL (LIST (CAR X) NAME))
+; (PUSH CELL UUF-FEXPR-ALIST)))
+; (CDR CELL)))
+; (T
+; (MERROR "Call to an undefined function '~A' at Lisp level."
+; (CAR X))))))
+;)
Well, these are kind of long diffs, but no difficult changes and they
reduce the warnings a bit. And the *merror thing is actually quite
severe I think.
I hope all this is of some use.
Andreas