aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/debug.lisp4
-rw-r--r--src/interp/macros.lisp10
-rw-r--r--src/interp/parsing.lisp6
-rw-r--r--src/interp/sys-macros.lisp10
-rw-r--r--src/interp/vmlisp.lisp51
5 files changed, 37 insertions, 44 deletions
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."))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-07 20:20:37 +0000