From 8a4f74e2a21557463176766306120b13fa80e457 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 3 Jul 2009 07:18:33 +0000 Subject: * interp/sys-macros.lisp (PRIMVEC2ARR): Remove. (COLLECTVEC): Likewise. * interp/compiler.boot (compRepeatOrCollect): Tidy. --- src/ChangeLog | 10 ++- src/algebra/strap/POLYCAT-.lsp | 162 ++++++++++++++++++++--------------------- src/interp/compiler.boot | 41 ++++------- src/interp/sys-macros.lisp | 11 +-- 4 files changed, 105 insertions(+), 119 deletions(-) (limited to 'src') 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 +2009-07-03 Gabriel Dos Reis + + * interp/sys-macros.lisp (PRIMVEC2ARR): Remove. + (COLLECTVEC): Likewise. + * interp/compiler.boot (compRepeatOrCollect): Tidy. + +2009-07-02 Gabriel Dos Reis 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 +2009-07-02 Gabriel Dos Reis * 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 -- cgit v1.2.3