From 0d7c8a950c87428e2a5183c617b22303858d8967 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 4 Feb 2008 01:39:22 +0000 Subject: * interp/foam_l.lisp (|G-stdoutVar|): Define; don't just assign. (|G-stdinVar|): Likewise. (|G-stderrVar|): Likewise. (|FormatNumber|): Bind local variable; don't just assign to it. (|magicEq1|): Tidy. * interp/debug.lisp: Don't declare `COUNT as SPECIAL. Remove reference to LISP package. Remove CCL special-cased definitions. * interp/comp.lisp ($closedfns): Define. * interp/cfuns.lisp (|getEnv|): Define only for GCL, for the time being. --- src/interp/cfuns.lisp | 1 + src/interp/comp.lisp | 2 ++ src/interp/debug.lisp | 95 +++----------------------------------------------- src/interp/foam_l.lisp | 29 ++++++++------- 4 files changed, 24 insertions(+), 103 deletions(-) (limited to 'src') diff --git a/src/interp/cfuns.lisp b/src/interp/cfuns.lisp index c9e33696..03fcdb0d 100644 --- a/src/interp/cfuns.lisp +++ b/src/interp/cfuns.lisp @@ -64,6 +64,7 @@ ; (|findString| (namestring p) str) ) +#+:GCL (defun |getEnv| (var-name) (system::getenv var-name)) ;;stolen from AXIOM-XL src/strops.c diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp index 23bb75ba..2f10f163 100644 --- a/src/interp/comp.lisp +++ b/src/interp/comp.lisp @@ -65,6 +65,8 @@ ; (defparameter OptionList nil) defined in nlib.lisp (defparameter SpecialVars nil) +(defvar $closedfns nil) + (defun |compAndDefine| (L) (let ((*comp370-apply* (function print-and-eval-defun))) (declare (special *comp370-apply*)) diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp index fbef4df2..3e3d28fb 100644 --- a/src/interp/debug.lisp +++ b/src/interp/debug.lisp @@ -130,13 +130,13 @@ ISID NBLNK COMMENTCHR $TOKSTACK (/SOURCEFILES |$sourceFiles|) METAKEYLST DEFINITION_NAME (|$sourceFileTypes| '(|spad| |boot| |lisp| |lsp| |meta|)) ($FUNCTION FN) $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK - TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE + TRAPFLAG |$InteractiveMode| TOK ERRCOL COLUMN *QUERY CHR LINE (*COMP370-APPLY* (if (eq op 'define) #'eval-defun #'compile-defun))) (declare (special ECHO-META SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM SPADERRORSTREAM ISID NBLNK COMMENTCHR $TOKSTACK /SOURCEFILES METAKEYLST DEFINITION_NAME |$sourceFileTypes| $FUNCTION $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK - TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE)) + TRAPFLAG |$InteractiveMode| TOK ERRCOL COLUMN *QUERY CHR LINE)) (if (PAIRP FN) (SETQ FN (QCAR FN))) (SETQ INFILE (OR INFILE (|getFunctionSourceFile| FN))) ;; $FUNCTION is freely set in getFunctionSourceFile @@ -388,7 +388,7 @@ EXAMINE (SETQ RECNO (NOTE INPUTSTREAM)) ;;;If A disk is not read-write, then issue msg and return. ;;;If /UPDATESTREAM not set or current /UPDATES file doesnt exist, initialize. - (PROG (IFT KEY RECNO ORECNO COUNT DATE TIME) + (PROG (IFT KEY RECNO ORECNO DATE TIME) ; (if (EQ 0 /VERSION) (RETURN NIL)) (if (EQ 'INPUT FT) (RETURN NIL)) (if (NOT |$createUpdateFiles|) (RETURN NIL)) @@ -741,7 +741,7 @@ EXAMINE (SETQ RECNO (NOTE INPUTSTREAM)) (DEFUN IS_SHARP_VAR (X) (AND (IDENTP X) (EQL (ELT (PNAME X) 0) #\#) - (INTEGERP (lisp:parse-integer (symbol-name X) :start 1)))) + (INTEGERP (parse-integer (symbol-name X) :start 1)))) (DEFUN MONITOR-GETVALUE (N FG) (COND ((= N 0) @@ -1120,47 +1120,6 @@ EXAMINE (SETQ RECNO (NOTE INPUTSTREAM)) (PRINT (LIST "CONTOUR LEVEL" CLEV)) (PRINT (mapcar #'car (car W)))))) -#+:CCL -(defun break (&rest ignore) (lisp-break ignore) (lisp::unwind)) - - -#+:CCL -(defun lisp-break (&rest ignore) - (prog (prompt ifile ofile u v) - (setq ifile (rds *debug-io*)) - (setq ofile (wrs *debug-io*)) - (setq prompt (setpchar "Break loop (:? for help)> ")) -top (setq u (read)) - (cond - ((equal u ':x) (go exit)) - ((equal u ':q) - (progn (lisp::enable-backtrace nil) - (princ "Backtrace now disabled") - (terpri))) - ((equal u ':v) - (progn (lisp::enable-backtrace t) - (princ "Backtrace now enabled") - (terpri))) - ((equal u ':?) - (progn - (princ ":Q disables backtrace") - (terpri) - (princ ":V enables backtrace") - (terpri) - (princ ":X exits from break loop") - (terpri) - (princ "else enter LISP expressions for evaluation") - (terpri))) - ((equal u #\eof) - (go exit)) - (t (progn - (setq v (errorset u nil nil)) - (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) - (go top) -exit (rds ifile) - (wrs ofile) - (setpchar prompt) - (return nil))) (defun lisp-break-from-axiom (&rest ignore) (boot::|handleLispBreakLoop| boot::|$BreakMode|)) @@ -1169,49 +1128,3 @@ exit (rds ifile) #-:CCL (defun interrupt (&rest ignore)) -#+:CCL -(defun interrupt (&rest ignore) - (prog (prompt ifile ofile u v) - (setq ifile (rds *debug-io*)) - (setq ofile (wrs *debug-io*)) - (setq prompt (setpchar "Break loop (:? for help)> ")) -top (setq u (read)) - (cond - ((equal u ':x) (go exit)) - ((equal u ':r) (go resume)) - ((equal u ':q) - (progn (lisp::enable-backtrace nil) - (princ "Backtrace now disabled") - (terpri))) - ((equal u ':v) - (progn (lisp::enable-backtrace t) - (princ "Backtrace now enabled") - (terpri))) - ((equal u ':?) - (progn - (princ ":Q disables backtrace") - (terpri) - (princ ":V enables backtrace") - (terpri) - (princ ":R resumes from break") - (terpri) - (princ ":X exits from break loop") - (terpri) - (princ "else enter LISP expressions for evaluation") - (terpri))) - ((equal u #\eof) - (go exit)) - (t (progn - (setq v (errorset u nil nil)) - (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) - (go top) -resume (rds ifile) - (wrs ofile) - (setpchar prompt) - (return nil) -exit (rds ifile) - (wrs ofile) - (setpchar prompt) - (lisp::unwind))) - - diff --git a/src/interp/foam_l.lisp b/src/interp/foam_l.lisp index 4a61f1e4..45b9f2da 100644 --- a/src/interp/foam_l.lisp +++ b/src/interp/foam_l.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007, Gabriel Dos Reis. +;; Copyright (C) 2007-2008, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -467,12 +467,12 @@ ;;(defvar |FoamOutputString| ;; (make-array 80 :element-type 'string-char :adjustable t :fill-pointer 0)) (defun |FormatNumber| (c arr i) - (setq str (format nil "~a" c)) - (replace arr str :start1 i) + (let ((str (format nil "~a" c))) + (replace arr str :start1 i) ;; (incf i (fill-pointer |FoamOutputString|)) ;; (if (> i (length arr)) (error "not enough space")) ;; (setf (fill-pointer |FoamOutputString|) 0) - (+ i (length str))) + (+ i (length str)))) (defmacro |FormatSFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) (defmacro |FormatDFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) @@ -882,12 +882,14 @@ (defun |fiGetDebugger| (x) ()) ;; Output ports -(setq |G-stdoutVar| t) -(setq |G-stdinVar| t) -(setq |G-stderrVar| t) +(defvar |G-stdoutVar| t) +(defvar |G-stdinVar| t) +(defvar |G-stderrVar| t) ;; !! Not portable !! -(defun foam::|fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) +;; ??? find a better way to get this work correctly and portably. +#+:GCL +(defun |fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) ;; These three functions check that two cons's contain identical entries. ;; We use EQL to test numbers and EQ everywhere else. If the structure @@ -906,8 +908,11 @@ (t (eq u v) ))) (defun |magicEq1| (u v) - (cond ( (and (atom u) (atom v)) (|politicallySound| u v)) - ( (or (atom u) (atom v)) nil) - ( (|politicallySound| (car u) (car v)) (|magicEq1| (cdr u) (cdr v))) - nil )) + (cond ((and (atom u) (atom v)) + (|politicallySound| u v)) + ((or (atom u) (atom v)) + nil) + ((|politicallySound| (car u) (car v)) + (|magicEq1| (cdr u) (cdr v))))) + -- cgit v1.2.3