diff options
| -rw-r--r-- | src/ChangeLog | 9 | ||||
| -rw-r--r-- | src/interp/debug.lisp | 4 | ||||
| -rw-r--r-- | src/interp/macros.lisp | 10 | ||||
| -rw-r--r-- | src/interp/parsing.lisp | 6 | ||||
| -rw-r--r-- | src/interp/sys-macros.lisp | 10 | ||||
| -rw-r--r-- | src/interp/vmlisp.lisp | 51 |
6 files changed, 46 insertions, 44 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index a64c9eba..dd81d8c0 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,14 @@ 2012-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/debug.lisp: ident? in lieu of IDENTP. + * interp/macros.lisp: Likewise. + * interp/parsing.lisp: Likewise. + * interp/sys-macros.lisp: Likewise. + * interp/vmlisp.lisp: Likewise. + (IDENTP): Remove. + +2012-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/ast.boot (bfNumber?): Rename from bfSmintable. Check for floating point literals too. Adjust callers. (bfLessp): Check for integer or floating pointer numbers. diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp index 3a00fcdb..5c4abac9 100644 --- a/src/interp/debug.lisp +++ b/src/interp/debug.lisp @@ -704,7 +704,7 @@ EXAMINE (SETQ RECNO (NOTE |$InputStream|)) ((OR (HAS_SHARP_VAR (CAR X)) (HAS_SHARP_VAR (CDR X)))))) (DEFUN IS_SHARP_VAR (X) - (AND (IDENTP X) + (AND (|ident?| X) (EQL (ELT (PNAME X) 0) #\#) (INTEGERP (parse-integer (symbol-name X) :start 1)))) @@ -1043,7 +1043,7 @@ EXAMINE (SETQ RECNO (NOTE |$InputStream|)) (defun BPITRACE (BPI ALIAS &optional OPTIONS) (let ((NEWNAME (GENSYM))) - (IF (identp bpi) (setq bpi (symbol-function bpi))) + (IF (|ident?| bpi) (setq bpi (symbol-function bpi))) (SETF (SYMBOL-VALUE NEWNAME) BPI) (SETF (symbol-function NEWNAME) BPI) (/TRACE-0 (APPEND (LIST NEWNAME (LIST 'ALIAS ALIAS)) OPTIONS)) diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp index 33d031aa..4ab528df 100644 --- a/src/interp/macros.lisp +++ b/src/interp/macros.lisp @@ -81,8 +81,8 @@ (if (ATOM V) (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) ((NUMBERP V) NIL) - ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) - ((IDENTP V) NIL) + ((|ident?| U) (AND (|ident?| V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) + ((|ident?| V) NIL) ((STRINGP U) (AND (STRINGP V) (string> V U))) ((STRINGP V) NIL) ((AND (simple-vector-p U) (simple-vector-p V)) @@ -128,12 +128,12 @@ (DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO))))) (DEFUN IS_GENVAR (X) - (AND (IDENTP X) + (AND (|ident?| X) (let ((y (symbol-name x))) (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) (DEFUN IS_\#GENVAR (X) - (AND (IDENTP X) + (AND (|ident?| X) (let ((y (symbol-name x))) (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1)))))) @@ -155,7 +155,7 @@ ; 14.1 Simple Sequence Functions (defun GETCHARN (A M) "Return the code of the Mth character of A" - (let ((a (if (identp a) (symbol-name a) a))) (char-code (elt A M)))) + (let ((a (if (|ident?| a) (symbol-name a) a))) (char-code (elt A M)))) ; 14.2 Concatenating, Mapping, and Reducing Sequences diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp index a8bf8ea3..5f52da48 100644 --- a/src/interp/parsing.lisp +++ b/src/interp/parsing.lisp @@ -500,7 +500,7 @@ the stack, then stack a NIL. Return the value of prod." a1 ;;(cond (ok (go b1))) (princ "/ok= NIL") b1 ;;(cond ( (not stackx) (go c1))) (princ "/stackx= ") ;;(prin1 stackx) - c1 (cond ( (not (identp tok)) (go d1))) + c1 (cond ( (not (|ident?| tok)) (go d1))) (princ "/isid= ") ;; (princ (cond (isid "T") (t "NIL"))) d1 (princ "/stack= ") (prin1 (|stackStore| |$reduceStack|)) @@ -515,7 +515,7 @@ the stack, then stack a NIL. Return the value of prod." (princ (if nonblank "T" "NIL")) a2 ;;(if ok (go b2)) (princ "/ok= ") (prin1 ok) b2 ;;(if (not stackx) (go c2)) (princ "/stackx1= ") (prin1 stackx) - c2 (if (not (identp tok)) (go d2)) + c2 (if (not (|ident?| tok)) (go d2)) (princ "/isid= ") ;; (princ (if isid "T" "NIL")) d2 (princ "/stack= ") (prin1 (|stackStore| |$reduceStack|)) @@ -590,7 +590,7 @@ the stack, then stack a NIL. Return the value of prod." ;; auxiliary functions needed by the parser (Defun FLOATEXPID (X &aux S) - (if (AND (IDENTP X) (char= (char-upcase (ELT (SETQ S (PNAME X)) 0)) #\E) + (if (AND (|ident?| X) (char= (char-upcase (ELT (SETQ S (PNAME X)) 0)) #\E) (> (LENGTH S) 1) (SPADREDUCE AND 0 (COLLECT (STEP I 1 1 (MAXINDEX S)) (DIGITP (ELT S I))))) diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp index 966626d2..95d4e898 100644 --- a/src/interp/sys-macros.lisp +++ b/src/interp/sys-macros.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2011, Gabriel Dos Reis. +;; Copyright (C) 2007-2012, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -134,7 +134,7 @@ #-:common-lisp (compile load eval) (defun IDENT-CHAR-LIT (x) (and (EQCAR x 'quote) - (IDENTP (cadr x)) + (|ident?| (cadr x)) (= (length (PNAME (cadr x))) 1)))) (defmacro BOOT-EQUAL (a b) @@ -690,7 +690,7 @@ ((CONS (|reverse!| LP) (MKPF L 'PROGN))))) (defun MK_LEFORM (U) - (COND ((IDENTP U) + (COND ((|ident?| U) (PNAME U)) ((STRINGP U) U) @@ -956,7 +956,7 @@ (if (OR (ATOM L) (ATOM (CDR L))) (GO BADO)) (setq vl (POP L)) - (COND ((IDENTP VL) + (COND ((|ident?| VL) (SETQ VARS (LIST VL)) (AND (OR (ATOM L) (ATOM (progn (setq inits (POP L)) L)) @@ -974,7 +974,7 @@ G180 (AND (NOT (CONSP (SETQ V (CAR VL)))) (SETQ V (LIST V))) - (AND (NOT (IDENTP (CAR V))) + (AND (NOT (|ident?| (CAR V))) (GO BADO)) (PUSH (CAR V) VARS) (PUSH (COND ((CONSP (CDR V)) (CADR V))) INITS) diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index 6282e0d4..bb74f3cd 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -147,13 +147,6 @@ (defmacro |idChar?| (x) `(or (alphanumericp ,x) (member ,x '(#\? #\% #\' #\!) :test #'char=))) -(defmacro identp (x) - (if (atom x) - `(and ,x (symbolp ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and ,xx (symbolp ,xx)))))) - (defmacro ifcar (x) (if (atom x) `(and (consp ,x) (qcar ,x)) @@ -494,7 +487,7 @@ (eq f 'fluid) (listp (cdr arglist)) (setq v (cadr arglist)) - (identp v) + (|ident?| v) (null (cddr arglist))) (push v *decl*) (push v *vars*) @@ -564,7 +557,7 @@ (defun upcase (l) (cond ((stringp l) (string-upcase l)) - ((identp l) (intern (string-upcase (symbol-name l)))) + ((|ident?| l) (intern (string-upcase (symbol-name l)))) ((characterp l) (char-upcase l)) ((atom l) l) (t (mapcar #'upcase l)))) @@ -574,7 +567,7 @@ (defun downcase (l) (cond ((stringp l) (string-downcase l)) - ((identp l) (intern (string-downcase (symbol-name l)))) + ((|ident?| l) (intern (string-downcase (symbol-name l)))) ((characterp l) (char-downcase L)) ((atom l) l) (t (mapcar #'downcase l)))) @@ -701,7 +694,7 @@ ; 17.0 Operations on Character and Bit Vectors (defun charp (a) (or (characterp a) - (and (identp a) (= (length (symbol-name a)) 1)))) + (and (|ident?| a) (= (length (symbol-name a)) 1)))) (defun NUM2CHAR (n) (code-char n)) @@ -876,7 +869,7 @@ (PROG (D A I L C W) (declare (special pvl avl)) (COND ((EQ FORM SV) (RETURN NIL)) - ((IDENTP FORM) (RETURN `((setq ,form ,sv)) )) + ((|ident?| FORM) (RETURN `((setq ,form ,sv)) )) ((simple-vector-p FORM) (RETURN (SEQ (setq L (length FORM)) @@ -888,7 +881,7 @@ (COND ((AND (NULL W) (OR (consp A) (simple-vector-p A))) (COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) ((setq PVL (CONS (setq W (GENSYM)) PVL)))))) - (setq C (|append!| (COND ((IDENTP A) `((setq ,a (ELT ,sv ,i)))) + (setq C (|append!| (COND ((|ident?| A) `((setq ,a (ELT ,sv ,i)))) ((OR (consp A) (simple-vector-p A)) `((setq ,w (ELT ,sv ,i)) ,@(dcqgenexp w a eqtag qflag)))) @@ -906,24 +899,24 @@ ((AND EQTAG (EQ (car FORM) EQTAG)) (RETURN (COND - ((OR (NOT (EQ 3 (LENGTH FORM))) (NOT (IDENTP (car (setq FORM (cdr FORM)))))) + ((OR (NOT (EQ 3 (LENGTH FORM))) (NOT (|ident?| (car (setq FORM (cdr FORM)))))) (MACRO-INVALIDARGS 'DCQ\/QDCQ FORM (MAKESTRING "invalid pattern."))) (`((setq ,(car form) ,sv) ,@(DCQGENEXP SV (CADR FORM) EQTAG QFLAG))))))) (setq A (car FORM)) (setq D (cdr FORM)) - (setq C (COND ((IDENTP A) `((setq ,a (CAR ,sv)))) + (setq C (COND ((|ident?| A) `((setq ,a (CAR ,sv)))) ((OR (consp A) (simple-vector-p A)) - (COND ((AND (NULL D) (IDENTP SV)) ) + (COND ((AND (NULL D) (|ident?| SV)) ) ((COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) (COND ((AND (consp A) EQTAG (EQ (car A) EQTAG)) (DCQGENEXP (LIST 'CAR SV) A EQTAG QFLAG) ) (`((setq ,(or w sv) (CAR ,sv)) ,@(DCQGENEXP (OR W SV) A EQTAG QFLAG))))))) - (setq C (|append!| C (COND ((IDENTP D) `((setq ,d (CDR ,sv)))) + (setq C (|append!| C (COND ((|ident?| D) `((setq ,d (CDR ,sv)))) ((OR (consp D) (simple-vector-p D)) (COND - ((OR W (IDENTP SV)) ) + ((OR W (|ident?| SV)) ) ((COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL)))) ) ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) @@ -967,7 +960,7 @@ (COND ((EQ FORM SV) (RETURN NIL)) ((OR - (IDENTP FORM) + (|ident?| FORM) (NUMP FORM) (AND (consp FORM) (EQ (qcar FORM) 'QUOTE))) (RETURN @@ -988,7 +981,7 @@ (|append!| (COND ( (OR - (IDENTP A) + (|ident?| A) (NUMP A) (AND (consp A) (EQ (qcar A) 'QUOTE))) `((COND ( (NOT (EQ ,a (ELT ,sv ,i))) @@ -1017,7 +1010,7 @@ (setq PVL (CONS (setq W (GENSYM)) PVL))) (setq C (COND - ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) + ( (OR (|ident?| A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) `((COND ((NOT (EQ ,a (CAR ,sv))) (GO BAD))) )) ( (OR (consp A) (simple-vector-p A)) `((setq ,w (CAR ,sv)) @@ -1026,7 +1019,7 @@ (|append!| C (COND - ( (OR (IDENTP D) (NUMP D) (AND (consp D) + ( (OR (|ident?| D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE))) `((COND ((NOT (EQ ,d (CDR ,sv))) (GO BAD))) )) ( (OR (consp D) (simple-vector-p D)) @@ -1089,7 +1082,7 @@ (|append!| (COND ( (OR - (IDENTP A) + (|ident?| A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) `((SETF (ELT ,sv ,i) ,a))) @@ -1121,7 +1114,7 @@ (setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) (setq C (COND - ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) + ( (OR (|ident?| A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) `((rplaca ,sv ,a))) ( (OR (consp A) (simple-vector-p A)) `((setq ,w (CAR ,sv)) @@ -1130,7 +1123,7 @@ (|append!| C (COND - ( (OR (IDENTP D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE))) + ( (OR (|ident?| D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE))) `((RPLACD ,sv ,d))) ( (OR (consp D) (simple-vector-p D)) `((setq ,sv (CDR ,sv)) @@ -1237,7 +1230,7 @@ (defun EMBED (CURRENT-BINDING NEW-DEFINITION) (PROG (OP BV BODY OLD-DEF) (COND - ( (NOT (IDENTP CURRENT-BINDING)) + ( (NOT (|ident?| CURRENT-BINDING)) (SETQ CURRENT-BINDING (error (format nil "invalid argument ~s to EMBED" CURRENT-BINDING))) ) ) (SETQ OLD-DEF (symbol-function CURRENT-BINDING)) @@ -1309,13 +1302,13 @@ (defun VARP (TEST-ITEM) (COND - ( (IDENTP TEST-ITEM) + ( (|ident?| TEST-ITEM) TEST-ITEM ) ( (AND (consp TEST-ITEM) (OR (EQ (QCAR TEST-ITEM) 'FLUID) (EQ (QCAR TEST-ITEM) 'LEX)) (consp (QCDR TEST-ITEM)) - (IDENTP (QCADR TEST-ITEM))) + (|ident?| (QCADR TEST-ITEM))) TEST-ITEM ) ( 'T NIL ) ) ) @@ -1340,7 +1333,7 @@ (defun doDSETQ (form pattern exp) (let (PVL AVL) (declare (special PVL AVL)) - (COND ((IDENTP PATTERN) + (COND ((|ident?| PATTERN) (LIST 'SETQ PATTERN EXP)) ((AND (NOT (consp PATTERN)) (NOT (simple-vector-p PATTERN))) (MACRO-INVALIDARGS 'DSETQ FORM "constant target.")) |