diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 9 | ||||
| -rw-r--r-- | src/interp/buildom.boot | 9 | ||||
| -rw-r--r-- | src/interp/debug.lisp | 7 | ||||
| -rw-r--r-- | src/interp/spad.lisp | 175 | ||||
| -rw-r--r-- | src/interp/sys-globals.boot | 3 | ||||
| -rw-r--r-- | src/interp/vmlisp.lisp | 4 |
6 files changed, 18 insertions, 189 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index c05e953d..cce2e321 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,14 @@ 2012-05-24 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/sys-globals.boot ($compCount): Remove. + * interp/spad.lisp (knownEqualPred): Move to buildom.boot + (hashable): Likewise. + Remove junk. + * interp/debug.lisp: Remove junk. + * interp/vmlisp.lisp: Likewise. + +2012-05-24 Gabriel Dos Reis <gdr@cs.tamu.edu> + * algebra/Makefile.in (initdb.$(FASLEXT)): Add --syslib to fix thinko. 2012-05-24 Gabriel Dos Reis <gdr@cs.tamu.edu> diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot index d6437cd5..9856c5e6 100644 --- a/src/interp/buildom.boot +++ b/src/interp/buildom.boot @@ -308,6 +308,15 @@ lookupInTable(op,sig,dollar,[domain,table]) == someMatch => lookupInAddChain(op,sig,domain,dollar) nil +knownEqualPred dom == + fun := compiledLookup("=",[$Boolean,"$","$"],dom) => + getFunctionReplacement BPINAME first fun + nil + +hashable dom == + -- FIXME: there should test for OIL opcodes. + symbolMember?(knownEqualPred dom,'(EQ EQL EQUAL)) + --% Record -- Want to eventually have the elts and setelts. -- Record is a macro in BUILDOM LISP. It takes out the colons. diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp index 917c91ff..18b3d2f6 100644 --- a/src/interp/debug.lisp +++ b/src/interp/debug.lisp @@ -62,13 +62,6 @@ (MAKEPROP 'INPUT '/TERMCHR '(#\: #\< #\ #\()) (MAKEPROP 'SPAD '/TERMCHR '(#\: #\< #\ #\()) (MAKEPROP 'BOOT '/TERMCHR '(#\: #\< #\ #\()) -(MAKEPROP 'META '/READFUN 'META\,RULE) -(MAKEPROP 'INPUT '/READFUN '|New,LEXPR,Interactive|) -(MAKEPROP 'INPUT '/TRAN '/TRANSPAD) -(MAKEPROP 'BOOT '/READFUN '|New,LEXPR1|) -(MAKEPROP 'BOOT '/TRAN '/TRANSNBOOT) -(MAKEPROP 'SPAD '/READFUN '|New,LEXPR|) -(MAKEPROP 'SPAD '/TRAN '/TRANSPAD) (defmacro |/C,LIB| (&rest L &aux optionlist /editfile ($prettyprint 't) ($reportCompilation 't)) diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp index fd2cedd6..4b203e9b 100644 --- a/src/interp/spad.lisp +++ b/src/interp/spad.lisp @@ -54,24 +54,8 @@ (defvar |$HiFiAccess| nil "if true maintain history file") (DEFVAR _ '&) -(defvar /EDIT-FM 'A1) -(defvar /EDIT-FT 'SPAD) -(defvar /RELEASE '"UNKNOWN") (defvar error-print) -(defvar ind) -(defvar INITCOLUMN 0) -(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) -(defvar m-chrbuffer) -(defvar m-chrindex) (defvar MARG 0 "Margin for testing by ?OP") -(defvar RLGENSYMFG NIL) -(defvar RLGENSYMLST NIL) -(defvar S-SPADTOK 'SPADSYSTOK) -(defvar sortpred) -(defvar SPADSYSKEY '(EOI EOL)) -(defvar STAKCOLUMN -1) -(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) -(defvar |InteractiveMode|) (defvar |uc| 'UC) (defun init-boot/spad-reader () @@ -139,70 +123,10 @@ (DEFUN INTEGER-BIT (N I) (LOGBITP I N)) -(DEFUN /TRANSPAD (X) - (PROG (proplist) - (setq proplist (LIST '(FLUID . |true|) - (CONS '|special| - (COPY-TREE |$InitialDomainsInScope|)))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (COPY-TREE |$InitialModemapFrame|)))) - (RETURN (PROGN (|translateSpad| X) NIL)))) - - ;; NIL needed below since END\_UNIT is not generated by current parser - -(defun |traceComp| () - (SETQ |$compCount| 0) - (EMBED '|comp| - '(LAMBDA (X Y Z) - (PROG (U) - (SETQ |$compCount| (1+ |$compCount|)) - (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) - (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) - ('T '|no|))) - (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") - (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) - (SETQ |$compCount| (1- |$compCount|)) - (RETURN U) ))) - (|comp| |$x| |$m| |$f|) - (UNEMBED '|comp|)) - -(defun UNCONS (X) - (COND ((ATOM X) X) - ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) - (T (ERROR "UNCONS")))) - -(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) - -(defun SPAD-PRINTTIME (A B) - (let (c msg) - (setq C (+ A B)) - (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) - " = " (STRINGIMAGE C) " MS.)")) - (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) - -(defun SPAD-MODETRAN (X) (D-TRAN X)) - -(defun SPAD-EVAL (X) - (COND ((ATOM X) (EVAL X)) - ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) - ;************************************************************************ ; SYSTEM COMMANDS ;************************************************************************ -(defun READLISP (UPPER_CASE_FG) - (let (v expr val ) - (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer |$spadLine|)) - (line-buffer |$spadLine|)) - t nil :start (Line-CURRENT-INDEX |$spadLine|))) - (VMPRINT EXPR) - (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) - (FORMAT t "~&VALUE = ~S" VAL) - (TERSYSCOMMAND))) - (defun TERSYSCOMMAND () (FRESH-LINE) (SETQ CHR 'ENDOFLINECHR) @@ -210,52 +134,16 @@ (|spadThrow|)) (defun /READ (L Q) -; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) -; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) -; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) -; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) (SETQ /EDITFILE L) (COND (Q (/RQ)) ('T (/RF)) ) (|terminateSystemCommand|)) -(defun /EF (&rest foo) - (|runCommand| (concat "vi " (namestring (make-input-filename /EDITFILE))))) - -(defun /EDIT (L) - (SETQ /EDITFILE L) - (/EF) - (|terminateSystemCommand|)) - -(defun /COMPINTERP (L OPTS) - (SETQ /EDITFILE (/MKINFILENAM L)) - (COND ((EQUAL OPTS "rf") (/RF)) - ((EQUAL OPTS "rq") (/RQ)) - ('T (/RQ-LIB))) - (|terminateSystemCommand|)) - (defun |fin| () (SETQ *EOF* 'T) (THROW 'SPAD_READER NIL)) - -(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) - -(defun STREAM2UC (STRM) - (LET ((X (ELT (LASTATOM STRM) 1))) (SETF (ELT X 0) (LC2UC (ELT X 0))))) - -(defun GP2COND (L) - (COND ((NOT L) (ERROR "GP2COND")) - ((NOT (CDR L)) - (COND ((EQCAR (FIRST L) 'COLON) - (CONS (SECOND L) (LIST (LIST T 'FAIL)))) - (T (LIST (LIST T (FIRST L)))) )) - ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) - (T (ERROR "GP2COND")))) - -(FLAG JUNKTOKLIST 'KEY) - (defmacro |DomainSubstitutionMacro| (&rest L) (|DomainSubstitutionFunction| (first L) (second L))) @@ -291,76 +179,22 @@ (declare (special |$autoLine|)) (|tryToFit| (|saveState|) ,X))) -(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) - -(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) - (DEFUN ASSOCIATER (FN LST) (COND ((NULL LST) NIL) ((NULL (CDR LST)) (CAR LST)) ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) -(defun ISLOCALOP-1 (IND) - "Curindex points at character after '.'" - (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) - (if (TERMINATOR NEWCHR) (RETURN NIL)) - (setq SELECTOR - (do ((x nil)) - (nil) - (if (terminator newchr) - (reverse x) - (push (setq newchr (nextcharacter)) x)))) - (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) - (setq BUF (|makeString| (LENGTH SELECTOR))) - (mapc #'(lambda (x) (suffix x buf)) selector) - (setq buf (copy-seq selector)) - (setq TERMTOK (INTERN BUF)) - (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) - (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) - (GET TERMTOK IND)) - (return TERMTOK))) ; **** X. Random tables (defvar $MARGIN 3) -(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) -(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) -(defvar LITTLEIN " in ") -(defvar INITALPHLIST ALPHLIST) -(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) -(defvar PORDLST (COPY-tree INITXPARLST)) -(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) -(defvar LITTLEA '|a|) -(defvar LITTLEI '|i|) -(defvar ALLSTAR NIL) (defvar PLUSS "+") -(defvar PERIOD ".") (defvar SLASH "/") (defvar COMMA ",") -(defvar LPAR "(") -(defvar RPAR ")") -(defvar EQSIGN "=") (defvar DASH "-") (defvar STAR "*") (defvar DOLLAR "$") (defvar COLON ":") -(FLAG TEMPGENSYMLIST 'IS-GENSYM) - - -;; NAME: DECIMAL-LENGTH -;; PURPOSE: Computes number of decimal digits in print representation of x -;; This should made as efficient as possible. - -(DEFUN DECIMAL-LENGTH (X) - (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) - (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) - (IF (< X 10) K (1+ K)))) - -;(DEFUN DECIMAL-LENGTH2 (X) -; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) -; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) - - ;; function to create byte and half-word vectors in new runtime system 8/90 (defun |makeByteWordVec| (initialvalue) @@ -375,15 +209,6 @@ :element-type (list 'mod (1+ n)) :initial-contents initialvalue))) -(defun |knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun (|getFunctionReplacement| (bpiname (car fun))) - nil))) - -(defun |hashable| (dom) - (|symbolMember?| (|knownEqualPred| dom) - '(EQ EQL EQUAL))) - ;; simpler interpface to RDEFIOSTREAM (defun RDEFINSTREAM (&rest fn) ;; following line prevents rdefiostream from adding a default filetype diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot index 397bd16e..f28f5f8d 100644 --- a/src/interp/sys-globals.boot +++ b/src/interp/sys-globals.boot @@ -61,9 +61,6 @@ $cacheAlist := nil $cacheCount := 0 ++ -$compCount := 0 - -++ $createUpdateFiles := false ++ diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index 002a8812..a6a0aa3a 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -342,7 +342,6 @@ (t (mapcar #'upcase l)))) (define-function 'U-CASE #'upcase) -(define-function 'LC2UC #'upcase) (defun downcase (l) (cond ((stringp l) (string-downcase l)) @@ -914,9 +913,6 @@ (let ((*print-pretty* t) (*print-array* t)) (prin1 x stream))) -(defun vmprint (x &optional (stream |$OutputStream|)) - (prin1 x stream) (terpri stream)) - (defun tab (sint &optional (stream t)) (format stream "~vT" sint)) |