diff options
Diffstat (limited to 'src/interp/patches.lisp.pamphlet')
| -rw-r--r-- | src/interp/patches.lisp.pamphlet | 423 |
1 files changed, 0 insertions, 423 deletions
diff --git a/src/interp/patches.lisp.pamphlet b/src/interp/patches.lisp.pamphlet deleted file mode 100644 index 25dd354f..00000000 --- a/src/interp/patches.lisp.pamphlet +++ /dev/null @@ -1,423 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp patches.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\subsection{toplevel} -The function top-level is the very root of the normal invocation -history stack. Control will pass to the restart function which is -also in this file. - -For some unknown reason toplevel was redefined to incorrectly -call lisp::unwind whereas it is defined (in this file) to be -interned in the boot package. We've returned toplevel to its -previous definition. -<<toplevel>>= -(defun toplevel (&rest foo) (throw '|top_level| '|restart|)) -;;(defun toplevel (&rest foo) (lisp::unwind)) - -@ -\section{License} -<<license>>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<<license>> - -(in-package "BOOT") -;;patches for now - -;; browser stuff: -;; gdr NOTES: it is WRONG to test for platforms, when in fact -;; gdr NOTES: one should test for functionalities. -#+:UNIX (defvar |$standard| 't) -#-:UNIX (defvar |$standard| 'nil) -#+(or :UNIX :winnt) (defvar |$saturn| 'nil) -#-(or :UNIX :winnt) (defvar |$saturn| 't) - -(defun CATCHALL (a &rest b) a) ;; not correct but ok for now -(defvar |$demoFlag| nil) - -(define-function '|construct| #'list) ;; NEEDED , SPAD-COMPILER generated Lisp code -(define-function '|COMP,TRAN| #'comp-tran) ;called by |compWithMappingMode| - -(defvar |Undef| (function |Undef|)) ;needed in NewbFVectorCopy -(define-function '|spadHash| #'sxhash) - -(defun |mkAutoLoad| (fn cname) - (function (lambda (&rest args) - (|autoLoad| fn cname) - (apply cname args)))) - -(setq |$printTimeIfTrue| nil) - - -(defmacro dribinit (streamvar) - `(if (is-console ,streamvar) - (setq ,streamvar *terminal-io*))) - -(defun |cd| (args) - (let ((dir (truename (string (or (car args) ""))))) - #+ :SBCL (sb-posix::chdir (namestring dir)) - #+ :GCL (system::chdir (namestring dir)) - #- (or :SBCL :GCL) (error "don't know how to chdir in this Lisp") - ;; FIXME: some Lisps may not properly end the name with slash - ;; investigate. - (setf *default-pathname-defaults* dir) - (|sayKeyedMsg| 'S2IZ0070 - (list (namestring *default-pathname-defaults*))))) - -<<toplevel>> -(define-function 'top-level #'toplevel) -(define-function 'unwind #'|spadThrow|) -(define-function 'resume #'|spadThrow|) - -(DEFUN BUMPCOMPERRORCOUNT () ()) - -(define-function '|isBpiOrLambda| #'FBOUNDP) -;;(defun |isSharpVar| (x) (and (identp x) (char= (elt (pname x) 0) #\#))) - -(setq |$useInternalHistoryTable| T) -(defvar |$internalHistoryTable| ()) -(setq |nullstream| '|nullstream|) -(setq |nonnullstream| '|nonnullstream|) -(defun |cpCms| (prefix &optional (string (|getSystemCommandLine|))) - (setq string (concat prefix string)) - (if (equal string "") (obey "sh") - (obey string)) - (|terminateSystemCommand|)) -(setq *print-escape* nil) ;; so stringimage doesn't escape idents? -#+(and :GCL :IEEE-FLOATING-POINT ) - (setq system:*print-nans* T) - -(defun /RF (&rest foo &aux (Echo-Meta 'T)) - (declare (special Echo-Meta)) - (/RF-1 nil)) - -(defun /RQ (&rest foo &aux (Echo-Meta nil)) - (declare (special Echo-Meta)) - (/RF-1 nil)) - -(defun |/RQ,LIB| (&rest foo &aux (Echo-Meta nil) ($LISPLIB T)) - (declare (special Echo-Meta $LISPLIB)) - (/RF-1 nil)) - -(defun /RF-1 (ignore) - (declare (ignore ignore)) - (let* ((input-file (make-input-filename /EDITFILE)) - (lfile ()) - (type (pathname-type input-file))) - (cond - ((string= type "boot") -#-:CCL - (boot input-file - (setq lfile (make-pathname :type "lisp" - :defaults input-file))) -#+:CCL - (boot input-file - (setq lfile (make-pathname :name (pathname-name input-file) - :type "lisp"))) - (load lfile)) - ((string= type "lisp") (load input-file)) - ((string= type "bbin") (load input-file)) - ((and (string= type "input") - |$useNewParser|) - (|ncINTERPFILE| input-file Echo-Meta)) - (t (spad input-file))))) - -(defun /EF (&rest foo) - (obey (concat "vi " (namestring (make-input-filename /EDITFILE))))) -#-:CCL - (defun user::start () (in-package "BOOT") (boot::|start|)) -#+:CCL - (defun user::start () (setq *package* (find-package "BOOT")) (boot::|start|)) - -(setq |$algebraOutputStream| - (setq |$fortranOutputStream| - (setq |$texOutputStream| - (setq |$formulaOutputStream| - (setq |conOutStream| (make-synonym-stream '*terminal-io*)))))) - -;; non-interactive restarts... -(defun restart0 () -#+(and :NAG :ccl) (lisp::init-lm 0) - (compressopen);; set up the compression tables - (interpopen);; open up the interpreter database - (operationopen);; all of the operations known to the system - (categoryopen);; answer hasCategory question - (browseopen) - (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) - (set-file-getter (strconc asharprootlib "runtime.o")) - (set-file-getter (strconc asharprootlib "lang.o")) - (set-file-getter (strconc asharprootlib "attrib.o")) - (set-file-getter (strconc asharprootlib "axlit.o")) - (set-file-getter (strconc asharprootlib "minimach.o")) - (set-file-getter (strconc asharprootlib "axextend.o"))) -) - -(defun SHAREDITEMS (x) T) ;;checked in history code -(defun whocalled (n) nil) ;; no way to look n frames up the stack -(defun setletprintflag (x) x) -(defun |normalizeTimeAndStringify| (time) - (if (= time 0.0) "0" (format nil "~,1F" time))) - -(define-function '|eval| #'eval) - -(defun |libraryFileLists| () '((SPAD SPADLIBS J))) - -;;--------------------> NEW DEFINITION (see cattable.boot.pamphlet) -(defun |compressHashTable| (ht) ht) -(defun GETZEROVEC (n) (MAKE-ARRAY n :initial-element 0)) - -(defun |normalizeArgFileName| (l) l) - -(defun READSPADEXPR () - (let* ((line (cdar (preparse in-stream)))) - (cond ((or (not (stringp line)) (zerop (SIZE line))) - (SAY " Scratchpad -- input") - (READSPADEXPR)) - (t (|parseTransform| (|postTransform| (|string2SpadTree| line))))))) - -(setq |$sourceFiles| ()) ;; set in readSpad2Cmd - -(setq |$localVars| ()) ;checked by isType - -(setq |$highlightFontOn| (concat " " |$boldString|)) -(setq |$highlightFontOff| (concat |$normalString| " ")) -(define-function 'SUBSTQ #'SUBSTEQ) ;; needed for substNames (always copy) -#+(and :lucid (not :ibm/370)) - (define-function 'RUN-AIX-PROGRAM #'SYS:RUN-AIX-PROGRAM) -;; following should be no longer necessary -;; (eval-when (eval load compile) (shadow 'delete)) -;; (define-function 'boot::delete #'|delete|) - -;; following code is to mimic def of MAP in NEWSPAD LISP -;; i.e. MAP in boot package is a self evaluating form -;; #-:CCL (eval-when (eval load compile) (shadow 'map)) -;; #-:CCL (defmacro map (&rest args) `'(map ,@args)) -(eval-when (eval load compile) (shadow 'map)) -(defmacro map (&rest args) `'(map ,@args)) - -#+:Lucid -(defun save-system (filename) - (in-package "BOOT") - (UNTRACE) - (|untrace| NIL) - (|clearClams|) - ;; bind output to nulloutstream - (let ((*standard-output* (make-broadcast-stream))) - (|resetWorkspaceVariables|)) - (setq |$specialCharacters| |$plainRTspecialCharacters|) - - (load (make-absolute-filename "lib/interp/obey")) - (system:disksave filename :restart-function restart-hook :full-gc t)) -#+:Lucid (define-function 'user::save-system #'boot::save-system) -(defun |undoINITIALIZE| () ()) -;; following are defined in spadtest.boot and stantest.boot -(defun |installStandardTestPackages| () ()) -(defun |spadtestValueHook| (val type) ()) -(defun |testError| (errotype erroValue) ()) -(defvar |$TestOptions| ()) -;; following in defined in word.boot -(defun |bootFind| (word) ()) -;; following 3 are replacements for g-util.boot -(define-function '|isLowerCaseLetter| #'LOWER-CASE-P) -(define-function '|isUpperCaseLetter| #'UPPER-CASE-P) -(define-function '|isLetter| #'ALPHA-CHAR-P) -;; reset from /spad/lisp/setq.lisp -(setq |$consistencyCheck| ()) ;; prevents wasting time checking consistency - - -#+(or :CCL (and :lucid :ibm/370)) -(setq $current-directory (truename ".")) -#-(or :CCL (and :lucid :ibm/370)) -(setq $current-directory (make-directory *default-pathname-defaults*)) - -(defvar *msghash* nil "hash table keyed by msg number") - -(defun cacheKeyedMsg (file) - (let ((line "") (msg "") key) - (with-open-file (in file) - (catch 'done - (loop - (setq line (read-line in nil nil)) - (cond - ((null line) - (when key - (setf (gethash key *msghash*) msg)) - (throw 'done nil)) - ((= (length line) 0)) - ((char= (schar line 0) #\S) - (when key - (setf (gethash key *msghash*) msg)) - (setq key (intern line "BOOT")) - (setq msg "")) - ('else - (setq msg (concatenate 'string msg line))))))))) - -(defun |fetchKeyedMsg| (key ignore) - (declare (ignore ignore)) - (setq key (|object2Identifier| key)) - (unless *msghash* - (setq *msghash* (make-hash-table)) - (cacheKeyedMsg |$defaultMsgDatabaseName|)) - (gethash key *msghash*)) - -#+:AKCL (proclaim '(ftype (function (t) t) identity)) -#+:AKCL (defun identity (x) x) - -(|initializeTimedNames| |$interpreterTimedNames| |$interpreterTimedClasses|) - -(defun |rebuild| (filemode) - "rebuild MODEMAP.DAASE, exit lisp with bad return code on failure" - (let ((returncode -16)) - (unwind-protect - (let (|$databaseQueue| |$e|) - (declare (special |$databaseQueue| |$e|)) - (|clearConstructorAndLisplibCaches|) - (setq |$databaseQueue| nil) - (setq |$e| (cons (cons nil nil) nil)) - (|buildDatabase| filemode t) - (setq |$IOindex| 1) - (setq |$InteractiveFrame| (cons (cons nil nil) nil)) - (setq returncode 0)) - (unless (zerop returncode) (bye returncode))))) - -#+:dos -(setq $current-directory (truename ".")) -#+:dos -(defun user-homedir-pathname () - (truename ".")) - -(defun boot::|printCopyright| () - (format t "there is no such thing as a simple job -- ((iHy))~%")) - -(defun |setViewportProcess| () - (setq |$ViewportProcessToWatch| - (stringimage (CDR - (|processInteractive| '(|key| (|%%| -2)) NIL) )))) - -(defun |waitForViewport| () - (progn - (do () - ((not (zerop (obey - (concat - "ps " - |$ViewportProcessToWatch| - " > /dev/null"))))) - ()) - (|sockSendInt| |$MenuServer| 1) - (|setIOindex| (- |$IOindex| 3)) - ) -) - - -(defun |makeVector| (els type) - (make-array (length els) :element-type (or type t) :initial-contents els)) - - -(defun |makeList| (size el) (make-list size :initial-element el) ) - -#+:akcl -(defun print-xdr-stream (x y z) (format y "XDR:~A" (xdr-stream-name x))) -#+:akcl -(defstruct (xdr-stream - (:print-function print-xdr-stream)) - "A structure to hold XDR streams. The stream is printed out." - (handle ) ;; this is what is used for xdr-open xdr-read xdr-write - (name )) ;; this is used for printing -#+(and :gcl (not (or :dos :win32))) -(defun |xdrOpen| (str dir) (make-xdr-stream :handle (system:xdr-open str) :name str)) -#+:CCL -(defun |xdrOpen| (str dir) (xdr-open str dir) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrOpen| (str dir) (format t "xdrOpen called")) - -#+(and :akcl (not (or :dos :win32))) -(defun |xdrRead| (xstr r) (system:xdr-read (xdr-stream-handle xstr) r) ) -#+:CCL -(defun |xdrRead| (xstr r) (xdr-read xstr r) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrRead| (str) (format t "xdrRead called")) - -#+(and :akcl (not (or :dos :win32))) -(defun |xdrWrite| (xstr d) (system:xdr-write (xdr-stream-handle xstr) d) ) -#+:CCL -(defun |xdrWrite| (xstr d) (xdr-write xstr d) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrWrite| (str) (format t "xdrWrite called")) - -;; here is a test for XDR -;; (setq *print-array* T) -;; (setq foo (open "xdrtest" :direction :output)) -;; (setq xfoo (|xdrOpen| foo)) -;; (|xdrWrite| xfoo "hello: This contains an integer, a float and a float array") -;; (|xdrWrite| xfoo 42) -;; (|xdrWrite| xfoo 3.14159) -;; (|xdrWrite| xfoo (make-array 10 :element-type 'long-float :initial-element 2.78111D12)) -;; (close foo) -;; (setq foo (open "xdrtest" :direction :input)) -;; (setq xfoo (|xdrOpen| foo)) -;; (|xdrRead| xfoo "") -;; (|xdrRead| xfoo 0) -;; (|xdrRead| xfoo 0.0) -;; (|xdrRead| xfoo (make-array 10 :element-type 'long-float )) -;; (setq *print-array* NIL) - -;; clearParserMacro has problems as boot code (package notation) -;; defined here in Lisp -;;--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -(DEFUN |clearParserMacro| (|macro|) - (PROG () - (RETURN (COND - ((NULL (IFCDR (|assoc| |macro| |$pfMacros|))) NIL) - ((QUOTE T) (SPADLET |$pfMacros| - (REMALIST |$pfMacros| |macro|))))))) -; - -(setq /MAJOR-VERSION 2) -(setq echo-meta nil) -(defun /versioncheck (n) (unless (= n /MAJOR-VERSION) (throw 'versioncheck -1))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} CMUCL {\bf src/interp/util.lisp.pamphlet} -\end{thebibliography} -\end{document} |