aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog10
-rw-r--r--src/algebra/strap/POLYCAT-.lsp162
-rw-r--r--src/interp/compiler.boot41
-rw-r--r--src/interp/sys-macros.lisp11
4 files changed, 105 insertions, 119 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index b2570de0..a0bf2157 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,11 +1,17 @@
-2009-07-02 Gabriel Dos Reis <gdr@cse.tamu.edu>
+2009-07-03 Gabriel Dos Reis <gdr@cse.tamu.edu>
+
+ * interp/sys-macros.lisp (PRIMVEC2ARR): Remove.
+ (COLLECTVEC): Likewise.
+ * interp/compiler.boot (compRepeatOrCollect): Tidy.
+
+2009-07-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
Support ECL-based build profiling.
* lisp/Makefile.in (edit): Substitute for oa_enable_profiling.
* lisp/core.lisp.in ($EnableLispProfiling): New.
(compileLispFile): Use it.
-2009-07-02 Gabriel Dos Reis <gdr@cse.tamu.edu>
+2009-07-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/sys-macros.lisp (COLLECTV): Use setSimpleArrayEntry, not
SETELT.
diff --git a/src/algebra/strap/POLYCAT-.lsp b/src/algebra/strap/POLYCAT-.lsp
index 3b73ad54..eb53dedb 100644
--- a/src/algebra/strap/POLYCAT-.lsp
+++ b/src/algebra/strap/POLYCAT-.lsp
@@ -1162,95 +1162,93 @@
|POLYCAT-;conditionP;MU;27|)
(EXIT
(CONS 0
- (PRIMVEC2ARR
- (PROGN
- (LETT #15#
- (GETREFV (SIZE |monslist|))
+ (PROGN
+ (LETT #15#
+ (GETREFV (SIZE |monslist|))
+ |POLYCAT-;conditionP;MU;27|)
+ (SEQ
+ (LETT #16# 0
|POLYCAT-;conditionP;MU;27|)
- (SEQ
- (LETT #16# 0
- |POLYCAT-;conditionP;MU;27|)
- (LETT |mons| NIL
- |POLYCAT-;conditionP;MU;27|)
- (LETT #17# |monslist|
- |POLYCAT-;conditionP;MU;27|)
- G190
- (COND
- ((OR (ATOM #17#)
- (PROGN
- (LETT |mons| (CAR #17#)
- |POLYCAT-;conditionP;MU;27|)
- NIL))
- (GO G191)))
- (SEQ
- (EXIT
- (|setSimpleArrayEntry| #15#
- #16#
+ (LETT |mons| NIL
+ |POLYCAT-;conditionP;MU;27|)
+ (LETT #17# |monslist|
+ |POLYCAT-;conditionP;MU;27|)
+ G190
+ (COND
+ ((OR (ATOM #17#)
(PROGN
- (LETT #21# NIL
+ (LETT |mons| (CAR #17#)
|POLYCAT-;conditionP;MU;27|)
+ NIL))
+ (GO G191)))
+ (SEQ
+ (EXIT
+ (|setSimpleArrayEntry| #15#
+ #16#
+ (PROGN
+ (LETT #21# NIL
+ |POLYCAT-;conditionP;MU;27|)
+ (SEQ
+ (LETT |m| NIL
+ |POLYCAT-;conditionP;MU;27|)
+ (LETT #18# |mons|
+ |POLYCAT-;conditionP;MU;27|)
+ G190
+ (COND
+ ((OR (ATOM #18#)
+ (PROGN
+ (LETT |m|
+ (CAR #18#)
+ |POLYCAT-;conditionP;MU;27|)
+ NIL))
+ (GO G191)))
(SEQ
- (LETT |m| NIL
- |POLYCAT-;conditionP;MU;27|)
- (LETT #18# |mons|
- |POLYCAT-;conditionP;MU;27|)
- G190
- (COND
- ((OR (ATOM #18#)
- (PROGN
- (LETT |m|
- (CAR #18#)
- |POLYCAT-;conditionP;MU;27|)
- NIL))
- (GO G191)))
- (SEQ
- (EXIT
- (PROGN
- (LETT #19#
- (SPADCALL |m|
+ (EXIT
+ (PROGN
+ (LETT #19#
+ (SPADCALL |m|
+ (SPADCALL
(SPADCALL
- (SPADCALL
- (QCDR |ans|)
- (LETT |i|
- (+ |i| 1)
- |POLYCAT-;conditionP;MU;27|)
- (|getShellEntry|
- $ 181))
+ (QCDR |ans|)
+ (LETT |i|
+ (+ |i| 1)
+ |POLYCAT-;conditionP;MU;27|)
(|getShellEntry|
- $ 51))
+ $ 181))
(|getShellEntry|
- $ 182))
- |POLYCAT-;conditionP;MU;27|)
- (COND
- (#21#
- (LETT #20#
- (SPADCALL #20#
- #19#
- (|getShellEntry|
- $ 183))
- |POLYCAT-;conditionP;MU;27|))
- ('T
- (PROGN
- (LETT #20#
- #19#
- |POLYCAT-;conditionP;MU;27|)
- (LETT #21# 'T
- |POLYCAT-;conditionP;MU;27|)))))))
- (LETT #18# (CDR #18#)
- |POLYCAT-;conditionP;MU;27|)
- (GO G190) G191
- (EXIT NIL))
- (COND
- (#21# #20#)
- ('T
- (|spadConstant| $ 27)))))))
- (LETT #17#
- (PROG1 (CDR #17#)
- (LETT #16# (QSADD1 #16#)
- |POLYCAT-;conditionP;MU;27|))
- |POLYCAT-;conditionP;MU;27|)
- (GO G190) G191 (EXIT NIL))
- #15#))))))))))
+ $ 51))
+ (|getShellEntry| $
+ 182))
+ |POLYCAT-;conditionP;MU;27|)
+ (COND
+ (#21#
+ (LETT #20#
+ (SPADCALL #20#
+ #19#
+ (|getShellEntry|
+ $ 183))
+ |POLYCAT-;conditionP;MU;27|))
+ ('T
+ (PROGN
+ (LETT #20# #19#
+ |POLYCAT-;conditionP;MU;27|)
+ (LETT #21# 'T
+ |POLYCAT-;conditionP;MU;27|)))))))
+ (LETT #18# (CDR #18#)
+ |POLYCAT-;conditionP;MU;27|)
+ (GO G190) G191
+ (EXIT NIL))
+ (COND
+ (#21# #20#)
+ ('T
+ (|spadConstant| $ 27)))))))
+ (LETT #17#
+ (PROG1 (CDR #17#)
+ (LETT #16# (QSADD1 #16#)
+ |POLYCAT-;conditionP;MU;27|))
+ |POLYCAT-;conditionP;MU;27|)
+ (GO G190) G191 (EXIT NIL))
+ #15#)))))))))
#10# (EXIT #10#)))))
(DEFUN |POLYCAT-;charthRoot;SU;28| (|p| $)
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 9d79c3b3..99bbac79 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -2217,7 +2217,7 @@ compReduce(form,m,e) ==
compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
[collectOp,:itl,body]:= collectForm
if STRINGP op then op:= INTERN op
- ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) =>
+ not MEMQ(collectOp,'(COLLECT COLLECTV)) =>
systemError ['"illegal reduction form:",form]
$sideEffectsList: local := nil
$until: local := nil
@@ -2269,6 +2269,7 @@ compRepeatOrCollect(form,m,e) ==
fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
$until: local := nil
oldEnv := e
+ aggr := nil
[repeatOrCollect,:itl,body]:= form
itl':=
[([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
@@ -2276,15 +2277,14 @@ compRepeatOrCollect(form,m,e) ==
targetMode:= first $exitModeStack
bodyMode:=
repeatOrCollect="COLLECT" =>
- targetMode = '$EmptyMode => '$EmptyMode
- (u:=modeIsAggregateOf('List,targetMode,e)) =>
- CADR u
- (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) =>
- repeatOrCollect:='COLLECTV
- CADR u
- (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
- repeatOrCollect:='COLLECTVEC
- CADR u
+ targetMode = $EmptyMode => (aggr:=["List",$EmptyMode]; $EmptyMode)
+ [aggr,u] := modeIsAggregateOf('List,targetMode,e) => u
+ [aggr,u] := modeIsAggregateOf('PrimitiveArray,targetMode,e) =>
+ repeatOrCollect := "COLLECTV"
+ u
+ [aggr,u] := modeIsAggregateOf('Vector,targetMode,e) =>
+ repeatOrCollect := "COLLECTV"
+ u
stackMessage('"Invalid collect bodytype")
return nil
-- If we're doing a collect, and the type isn't conformable
@@ -2296,16 +2296,8 @@ compRepeatOrCollect(form,m,e) ==
[untilCode,.,e']:= comp($until,$Boolean,e')
itl':= substitute(["UNTIL",untilCode],'$until,itl')
form':= [repeatOrCollect,:itl',body']
- m'':=
- repeatOrCollect="COLLECT" =>
- (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u
- ["List",m']
- repeatOrCollect="COLLECTV" =>
- (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u
- ["PrimitiveArray",m']
- repeatOrCollect="COLLECTVEC" =>
- (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u
- ["Vector",m']
+ m'' :=
+ aggr is [c,.] and MEMQ(c,'(List PrimitiveArray Vector)) => [c,m']
m'
T := coerceExit([form',m'',e'],targetMode) or return nil
-- iterator variables and other variables declared in
@@ -2410,16 +2402,15 @@ compIterator(it,e) ==
-- m
-- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R
-modeIsAggregateOf(ListOrVector,m,e) ==
- m is [ =ListOrVector,R] => [m,R]
---m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY +
+modeIsAggregateOf(agg,m,e) ==
+ m is [ =agg,R] => [m,R]
m is ["Union",:l] =>
- mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))]
+ mList:= [pair for m' in l | (pair:= modeIsAggregateOf(agg,m',e))]
1=#mList => first mList
name:=
m is [fn,:.] => fn
RepIfRepHack m
- get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R]
+ get(name,"value",e) is [[ =agg,R],:.] => [m,R]
--% VECTOR ITERATORS
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index 1224c6a3..b610af09 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-2008, Gabriel Dos Reis.
+;; Copyright (C) 2007-2009, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -1205,15 +1205,6 @@
(let ((U (REPEAT-TRAN L NIL)))
(CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U)))))))
-;; The following was changed to a macro for efficiency in CCL. To change
-;; it back to a function would require recompilation of a large chunk of
-;; the library.
-(defmacro PRIMVEC2ARR (x)
- x) ;redefine to change Array rep
-
-(defmacro COLLECTVEC (&rest L)
- `(PRIMVEC2ARR (COLLECTV ,@L)))
-
(defmacro COLLECTV (&rest L)
(PROG (CONDS BODY ANS COUNTER X Y)
;;If we can work out how often we will go round
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 13:07:10 +0000