aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog7
-rw-r--r--src/interp/macros.lisp76
-rw-r--r--src/interp/spad.lisp11
-rw-r--r--src/interp/sys-macros.lisp63
4 files changed, 13 insertions, 144 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 366e7943..44815356 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,12 @@
2011-05-01 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/macros.lisp (WI, tryLine, embrace indentNB, tryBreak)
+ (tryBreakNB, MARKHASH): Remove.
+ * interp/spad.lisp (NEWNAMTRANS): Likewise.
+ * interp/sys-macros.lisp: Remove more Lispy junk.
+
+2011-05-01 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* boot/utility.boot (applySubstNQ): New.
* interp/compiler.boot (finishLambdaExpression): Use it.
* interp/i-intern.boot (mkAtreeExpandMacros): Likewise.
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index e2dbf4f1..0deffb0e 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -232,14 +232,14 @@
;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added)
;; destructive on L; if (A . C) appears already, C is replaced by B
(cond ((null l) (list (cons a b)))
- ((equal a (caar l)) (rplac (cdar l) b) l)
+ ((equal a (caar l)) (rplacd (car l) b) l)
((?order a (caar l)) (cons (cons a b) l))
(t (as-insert1 a b l) l)))
(defun as-insert1 (a b l)
- (cond ((null (cdr l)) (rplac (cdr l) (list (cons a b))))
- ((equal a (caadr l)) (rplac (cdadr l) b))
- ((?order a (caadr l)) (rplac (cdr l) (cons (cons a b) (cdr l))))
+ (cond ((null (cdr l)) (rplacd l (list (cons a b))))
+ ((equal a (caadr l)) (rplacd (cadr l) b))
+ ((?order a (caadr l)) (rplacd l (cons (cons a b) (cdr l))))
(t (as-insert1 a b (cdr l)))))
@@ -655,77 +655,9 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(setq bol (+ eol 1)))
(|reverse!| line-list)))
-; part of the old spad to new spad translator
-; these are here because they need to be in depsys
-; they were in nspadaux.lisp
-
-(defmacro wi (a b) b)
-
-(defmacro |tryLine| (X)
- `(LET ((|$autoLine|))
- (declare (special |$autoLine|))
- (|tryToFit| (|saveState|) ,X)))
-
-(defmacro |embrace| (X) `(|wrapBraces| (|saveC|) ,X (|restoreC|)))
-(defmacro |indentNB| (X) `(|wrapBraces| (|saveD|) ,X (|restoreD|)))
-
-(defmacro |tryBreak| (a b c d)
-; Try to format <a b> by:
-; (1) with no line breaking ($autoLine = nil)
-; (2) with possible line breaks within a;
-; (3) otherwise use a brace
- `(LET
- ((state))
- (setq state (|saveState| 't))
- (or
- (LET ((|$autoLine|))
- (declare (special |$autoLine|))
- (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d)))
- (|restoreState| state)
- (and (eqcar ,b (quote seq))
- (|embrace| (and
- ,a
- (|formatLB|)
- (|formatRight| '|formatPreferPile| ,b ,c ,d))))
- (|restoreState| state)
- (|embrace| (and ,a
- (|formatLB|)
- (|formatRight| '|formatPreferPile| ,b ,c ,d))))))
-
-(defmacro |tryBreakNB| (a b c d)
-; Try to format <a b> by:
-; (1) with no line breaking ($autoLine = nil)
-; (2) with possible line breaks within a;
-; (3) otherwise display without a brace
- `(LET
- ((state))
- (setq state (|saveState| 't))
- (or
- (markhash ,b 0)
- (LET ((|$autoLine|))
- (declare (special |$autoLine|))
- (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d)))
- (|restoreState| state)
- (markhash ,b 1)
- (and (eqcar ,b (quote seq))
- (|embrace| (and
- ,a
- (|formatLB|)
- (|formatRight| '|formatPreferPile| ,b ,c ,d))))
- (markhash ,b 2)
- (|restoreState| state)
- (|indentNB| (and ,a
- (|formatRight| '|formatPreferPile| ,b ,c ,d)))
- (markhash ,b 3)
-
-)))
(defvar HT nil)
-(defun markhash (key n) (progn (cond
- ((equal n 3) (remhash key ht))
- ('t (hput ht key n)) ) nil))
-
;;
;; -*- Record Structures -*-
;;
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index 853fcbc8..b81fea44 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2010, Gabriel Dos Reis.
+;; Copyright (C) 2007-2011, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -215,15 +215,6 @@
(defun STREAM2UC (STRM)
(LET ((X (ELT (LASTATOM STRM) 1))) (SETF (ELT X 0) (LC2UC (ELT X 0)))))
-(defun NEWNAMTRANS (X)
- (COND
- ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X)))
- ((STRINGP X) X)
- ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS)))
- ((ATOM X) X)
- ((EQCAR X 'QUOTE))
- (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X))))))
-
(defun GP2COND (L)
(COND ((NOT L) (ERROR "GP2COND"))
((NOT (CDR L))
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index 6a21d4b3..7baf2a65 100644
--- a/src/interp/sys-macros.lisp
+++ b/src/interp/sys-macros.lisp
@@ -217,67 +217,6 @@
))
-
-;;
-;; -*- Cons Cell Manipulators -*-
-;;
-
-(eval-when
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (progn
- (MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J)))
- '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7)
- (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12)
- (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17)
- (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22)
- (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27)
- (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31)))
-
- (DEFUN RENAME (U)
- (let (x)
- (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM)))
- X
- U)))
-
- (defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR
- (COND ((< N 1)
- (fail))
- ((EQL N 1)
- X)
- ((let ((D (DIVIDE N 2)))
- (CARCDRX1 (LIST (if (EQL (CADR D) 0)
- (if FG 'CAR 'CAR)
- (if FG 'CDR 'CDR)) X)
- (CAR D)
- FG)))))
-
- (defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR
- (let (n hx)
- (COND ((ATOM X)
- X)
- ((SETQ N
- (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG)))
- 'SELCODE))
- (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG))
- ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X)))))))
- ))
-
-
-(defmacro RPLAC (&rest L)
- (if (EQCAR (CAR L) 'ELT)
- (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L))
- (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L)))
- (COND ((CDDR L) (ERROR 'RPLAC))
- ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B))
- ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B))
- ((ERROR 'RPLAC))))))
-
-;;
-;; -*- Association Lists -*-
-;;
-
-
;;
;; -*- Simple Arrays -*-
;;
@@ -1107,7 +1046,7 @@
`(theta CONS . ,(CDR L))
(progn
(if (EQCAR (CAR L) 'QUOTE)
- (RPLAC (CAR L) (CADAR L)))
+ (RPLACA L (CADAR L)))
(-REDUCE (CAR L) 0
(if (SETQ U (GET (CAR L) 'THETA))
(CAR U)
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-29 23:51:15 +0000