diff --git a/dev/Updates/multi-index b/dev/Updates/multi-index new file mode 100644 index 0000000000..6a1a809e81 --- /dev/null +++ b/dev/Updates/multi-index @@ -0,0 +1,29 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Format 'yyyy/mm/dd' +!! Date +2015/03/18 +!! Changed by +SL +! Reported by + +!! Type of Change +New: extended functionality + +!! Description + +Kernel support for accessing lists using multiple indices. +This doesn't do anything by itself but allows library or packages +to install methods supporting expressions like +m[1,2]; +m[1,2,3] := x; +IsBound(m["a","b",Z(7)]); +Unbind(m[1][2,3]) + + +! Test Code + +! Prefetch + +!! Changeset + +!! End diff --git a/lib/list.gd b/lib/list.gd index 9f607b5dcd..32899e57b0 100644 --- a/lib/list.gd +++ b/lib/list.gd @@ -164,7 +164,7 @@ DeclareAttributeKernel( "Length", IsList, LENGTH ); ## <#/GAPDoc> ## DeclareOperationKernel( "IsBound[]", - [ IsList, IS_INT ], + [ IsList, IsObject ], ISB_LIST ); @@ -173,7 +173,7 @@ DeclareOperationKernel( "IsBound[]", #o [] . . . . . . . . . . . . . . . select an element from a list ## DeclareOperationKernel( "[]", - [ IsList, IS_INT ], + [ IsList, IsObject ], ELM_LIST ); @@ -234,7 +234,7 @@ DeclareOperationKernel( "Elm0List", ## <#/GAPDoc> ## DeclareOperationKernel( "Unbind[]", - [ IsList and IsMutable, IS_INT ], + [ IsList and IsMutable, IsObject ], UNB_LIST ); @@ -243,7 +243,7 @@ DeclareOperationKernel( "Unbind[]", #o [] := ## DeclareOperationKernel( "[]:=", - [ IsList and IsMutable, IS_INT, IsObject ], + [ IsList and IsMutable, IsObject, IsObject ], ASS_LIST ); diff --git a/src/code.c b/src/code.c index 8082e1685f..8cc2afe6c3 100644 --- a/src/code.c +++ b/src/code.c @@ -2353,20 +2353,24 @@ void CodeIsbGVar ( *F CodeAssListLevel( ) . . . . . . code assignment to several lists *F CodeAsssListLevel( ) . code multiple assignment to several lists */ -void CodeAssListUniv ( - Stat ass ) +void CodeAssListUniv ( + Stat ass, + Int narg) { Expr list; /* list expression */ Expr pos; /* position expression */ Expr rhsx; /* right hand side expression */ + Int i; /* enter the right hand side expression */ rhsx = PopExpr(); - ADDR_STAT(ass)[2] = (Stat)rhsx; + ADDR_STAT(ass)[narg+1] = (Stat)rhsx; /* enter the position expression */ - pos = PopExpr(); - ADDR_STAT(ass)[1] = (Stat)pos; + for (i = narg; i > 0; i--) { + pos = PopExpr(); + ADDR_STAT(ass)[i] = (Stat)pos; + } /* enter the list expression */ list = PopExpr(); @@ -2376,15 +2380,25 @@ void CodeAssListUniv ( PushStat( ass ); } -void CodeAssList ( void ) +void CodeAssList ( Int narg ) { Stat ass; /* assignment, result */ /* allocate the assignment */ - ass = NewStat( T_ASS_LIST, 3 * sizeof(Stat) ); + switch (narg) { + case 1: + ass = NewStat( T_ASS_LIST, 3 * sizeof(Stat) ); + break; + + case 2: + ass = NewStat(T_ASS2_LIST, 4* sizeof(Stat)); + break; + default: + ass = NewStat(T_ASSX_LIST, (narg + 2)*sizeof(Stat)); + } /* let 'CodeAssListUniv' do the rest */ - CodeAssListUniv( ass ); + CodeAssListUniv( ass, narg ); } void CodeAsssList ( void ) @@ -2395,20 +2409,20 @@ void CodeAsssList ( void ) ass = NewStat( T_ASSS_LIST, 3 * sizeof(Stat) ); /* let 'CodeAssListUniv' do the rest */ - CodeAssListUniv( ass ); + CodeAssListUniv( ass, 1 ); } -void CodeAssListLevel ( +void CodeAssListLevel ( Int narg, UInt level ) { Stat ass; /* assignment, result */ /* allocate the assignment and enter the level */ - ass = NewStat( T_ASS_LIST_LEV, 4 * sizeof(Stat) ); - ADDR_STAT(ass)[3] = (Stat)level; + ass = NewStat( T_ASS_LIST_LEV, (narg +3) * sizeof(Stat) ); + ADDR_STAT(ass)[narg+2] = (Stat)level; /* let 'CodeAssListUniv' do the rest */ - CodeAssListUniv( ass ); + CodeAssListUniv( ass, narg ); } void CodeAsssListLevel ( @@ -2421,7 +2435,7 @@ void CodeAsssListLevel ( ADDR_STAT(ass)[3] = (Stat)level; /* let 'CodeAssListUniv' do the rest */ - CodeAssListUniv( ass ); + CodeAssListUniv( ass, 1 ); } @@ -2429,18 +2443,21 @@ void CodeAsssListLevel ( ** *F CodeUnbList() . . . . . . . . . . . . . . . code unbind of list position */ -void CodeUnbList ( void ) +void CodeUnbList ( Int narg ) { Expr list; /* list expression */ Expr pos; /* position expression */ Stat ass; /* unbind, result */ + Int i; /* allocate the unbind */ - ass = NewStat( T_UNB_LIST, 2 * sizeof(Stat) ); + ass = NewStat( T_UNB_LIST, (narg+1) * sizeof(Stat) ); - /* enter the position expression */ - pos = PopExpr(); - ADDR_STAT(ass)[1] = (Stat)pos; + /* enter the position expressions */ + for (i = narg; i > 0; i--) { + pos = PopExpr(); + ADDR_STAT(ass)[i] = (Stat)pos; + } /* enter the list expression */ list = PopExpr(); @@ -2459,14 +2476,19 @@ void CodeUnbList ( void ) *F CodeElmsListLevel( ) . code multiple selection of several lists */ void CodeElmListUniv ( - Expr ref ) + Expr ref, + Int narg) { Expr list; /* list expression */ Expr pos; /* position expression */ + Int i; /* enter the position expression */ - pos = PopExpr(); - ADDR_EXPR(ref)[1] = pos; + + for (i = narg; i > 0; i--) { + pos = PopExpr(); + ADDR_EXPR(ref)[i] = pos; + } /* enter the list expression */ list = PopExpr(); @@ -2476,15 +2498,21 @@ void CodeElmListUniv ( PushExpr( ref ); } -void CodeElmList ( void ) +void CodeElmList ( Int narg ) { Expr ref; /* reference, result */ - /* allocate the reference */ - ref = NewExpr( T_ELM_LIST, 2 * sizeof(Expr) ); - - /* let 'CodeElmListUniv' to the rest */ - CodeElmListUniv( ref ); + /* allocate the reference */ + if (narg == 1) + ref = NewExpr( T_ELM_LIST, 2 * sizeof(Expr) ); + else if (narg == 2) + ref = NewExpr( T_ELM2_LIST, 3 * sizeof(Expr) ); + else + ref = NewExpr( T_ELMX_LIST, (narg + 1) *sizeof(Expr)); + + /* let 'CodeElmListUniv' to the rest */ + CodeElmListUniv( ref, narg ); + } void CodeElmsList ( void ) @@ -2495,20 +2523,20 @@ void CodeElmsList ( void ) ref = NewExpr( T_ELMS_LIST, 2 * sizeof(Expr) ); /* let 'CodeElmListUniv' to the rest */ - CodeElmListUniv( ref ); + CodeElmListUniv( ref, 1 ); } -void CodeElmListLevel ( +void CodeElmListLevel ( Int narg, UInt level ) { Expr ref; /* reference, result */ - /* allocate the reference and enter the level */ - ref = NewExpr( T_ELM_LIST_LEV, 3 * sizeof(Expr) ); - ADDR_EXPR(ref)[2] = (Stat)level; + ref = NewExpr( T_ELM_LIST_LEV, (narg+2)*sizeof(Expr)); + ADDR_EXPR(ref)[narg+1] = (Stat)level; + /* let 'CodeElmListUniv' do the rest */ - CodeElmListUniv( ref ); + CodeElmListUniv( ref, narg ); } void CodeElmsListLevel ( @@ -2521,7 +2549,7 @@ void CodeElmsListLevel ( ADDR_EXPR(ref)[2] = (Stat)level; /* let 'CodeElmListUniv' do the rest */ - CodeElmListUniv( ref ); + CodeElmListUniv( ref, 1 ); } @@ -2529,18 +2557,21 @@ void CodeElmsListLevel ( ** *F CodeIsbList() . . . . . . . . . . . . . . code bound list position check */ -void CodeIsbList ( void ) +void CodeIsbList ( Int narg ) { Expr ref; /* isbound, result */ Expr list; /* list expression */ Expr pos; /* position expression */ + Int i; /* allocate the isbound */ - ref = NewExpr( T_ISB_LIST, 2 * sizeof(Expr) ); + ref = NewExpr( T_ISB_LIST, (narg + 1) * sizeof(Expr) ); /* enter the position expression */ - pos = PopExpr(); - ADDR_EXPR(ref)[1] = pos; + for (i = narg; i > 0; i--) { + pos = PopExpr(); + ADDR_EXPR(ref)[i] = pos; + } /* enter the list expression */ list = PopExpr(); diff --git a/src/code.h b/src/code.h index acc0195630..c2d7b755b7 100644 --- a/src/code.h +++ b/src/code.h @@ -387,7 +387,12 @@ Obj FILENAME_STAT(Stat stat); #define T_FLOAT_EXPR_EAGER (FIRST_EXPR_TNUM+82) #define T_FLOAT_EXPR_LAZY (FIRST_EXPR_TNUM+83) -#define LAST_EXPR_TNUM T_FLOAT_EXPR_LAZY +#define T_ELM2_LIST (FIRST_EXPR_TNUM+84) +#define T_ELMX_LIST (FIRST_EXPR_TNUM+85) +#define T_ASS2_LIST (FIRST_EXPR_TNUM+86) +#define T_ASSX_LIST (FIRST_EXPR_TNUM+87) + +#define LAST_EXPR_TNUM T_ASSX_LIST /**************************************************************************** @@ -1153,17 +1158,17 @@ extern void CodeIsbGVar ( *F CodeAssListLevel() . . . . . . . code assignment to several lists *F CodeAsssListLevel() . . code multiple assignment to several lists */ -extern void CodeAssList ( void ); +extern void CodeAssList ( Int narg ); extern void CodeAsssList ( void ); -extern void CodeAssListLevel ( +extern void CodeAssListLevel ( Int narg, UInt level ); extern void CodeAsssListLevel ( UInt level ); -extern void CodeUnbList ( void ); +extern void CodeUnbList ( Int narg ); /**************************************************************************** @@ -1173,17 +1178,18 @@ extern void CodeUnbList ( void ); *F CodeElmListLevel() . . . . . . . . code selection of several lists *F CodeElmsListLevel() . . code multiple selection of several lists */ -extern void CodeElmList ( void ); +extern void CodeElmList ( Int narg ); extern void CodeElmsList ( void ); extern void CodeElmListLevel ( - UInt level ); + Int narg, + UInt level); extern void CodeElmsListLevel ( UInt level ); -extern void CodeIsbList ( void ); +extern void CodeIsbList ( Int narg ); /**************************************************************************** diff --git a/src/compiled.h b/src/compiled.h index c6f99e9378..07f891c440 100644 --- a/src/compiled.h +++ b/src/compiled.h @@ -116,10 +116,10 @@ typedef UInt RNam; if ( ! IS_INTOBJ(obj) ) ErrorQuitIntSmall(obj); #define CHECK_INT_SMALL_POS(obj) \ - if ( ! IS_INTOBJ(obj) || INT_INTOBJ(obj) <= 0 ) ErrorQuitIntSmallPos(obj); + if ( ! IS_POS_INTOBJ(obj) ) ErrorQuitIntSmallPos(obj); #define CHECK_INT_POS(obj) \ - if ( TNUM_OBJ(obj) != T_INTPOS && (! IS_INTOBJ(obj) || INT_INTOBJ(obj) <= 0) ) ErrorQuitIntPos(obj); + if ( TNUM_OBJ(obj) != T_INTPOS && ( ! IS_POS_INTOBJ(obj)) ) ErrorQuitIntPos(obj); #define CHECK_BOOL(obj) \ if ( obj != True && obj != False ) ErrorQuitBool(obj); @@ -241,13 +241,13 @@ typedef UInt RNam; #define C_ELM_LIST(elm,list,p) \ - elm = IS_INTOBJ(p) ? ELM_LIST( list, INT_INTOBJ(p) ) : ELMB_LIST(list, p); + elm = IS_POS_INTOBJ(p) ? ELM_LIST( list, INT_INTOBJ(p) ) : ELMB_LIST(list, p); #define C_ELM_LIST_NLE(elm,list,p) \ - elm = IS_INTOBJ(p) ? ELMW_LIST( list, INT_INTOBJ(p) ) : ELMB_LIST(list, p); + elm = IS_POS_INTOBJ(p) ? ELMW_LIST( list, INT_INTOBJ(p) ) : ELMB_LIST(list, p); #define C_ELM_LIST_FPL(elm,list,p) \ - if ( IS_INTOBJ(p) && IS_PLIST(list) ) { \ + if ( IS_POS_INTOBJ(p) && IS_PLIST(list) ) { \ if ( INT_INTOBJ(p) <= LEN_PLIST(list) ) { \ elm = ELM_PLIST( list, INT_INTOBJ(p) ); \ if ( elm == 0 ) elm = ELM_LIST( list, INT_INTOBJ(p) ); \ @@ -255,16 +255,16 @@ typedef UInt RNam; } else C_ELM_LIST( elm, list, p ) #define C_ELM_LIST_NLE_FPL(elm,list,p) \ - if ( IS_INTOBJ(p) && IS_PLIST(list) ) { \ + if ( IS_POS_INTOBJ(p) && IS_PLIST(list) ) { \ elm = ELM_PLIST( list, INT_INTOBJ(p) ); \ } else C_ELM_LIST_NLE(elm, list, p) #define C_ASS_LIST(list,p,rhs) \ - if (IS_INTOBJ(p)) ASS_LIST( list, INT_INTOBJ(p), rhs ); \ + if (IS_POS_INTOBJ(p)) ASS_LIST( list, INT_INTOBJ(p), rhs ); \ else ASSB_LIST(list, p, rhs); #define C_ASS_LIST_FPL(list,p,rhs) \ - if ( IS_INTOBJ(p) && TNUM_OBJ(list) == T_PLIST ) { \ + if ( IS_POS_INTOBJ(p) && TNUM_OBJ(list) == T_PLIST ) { \ if ( LEN_PLIST(list) < INT_INTOBJ(p) ) { \ GROW_PLIST( list, (UInt)INT_INTOBJ(p) ); \ SET_LEN_PLIST( list, INT_INTOBJ(p) ); \ @@ -277,7 +277,7 @@ typedef UInt RNam; } #define C_ASS_LIST_FPL_INTOBJ(list,p,rhs) \ - if ( IS_INTOBJ(p) && TNUM_OBJ(list) == T_PLIST) { \ + if ( IS_POS_INTOBJ(p) && TNUM_OBJ(list) == T_PLIST) { \ if ( LEN_PLIST(list) < INT_INTOBJ(p) ) { \ GROW_PLIST( list, (UInt)INT_INTOBJ(p) ); \ SET_LEN_PLIST( list, INT_INTOBJ(p) ); \ @@ -289,10 +289,10 @@ typedef UInt RNam; } #define C_ISB_LIST( list, pos) \ - ((IS_INTOBJ(pos) ? ISB_LIST(list, INT_INTOBJ(pos)) : ISBB_LIST( list, pos)) ? True : False) + ((IS_POS_INTOBJ(pos) ? ISB_LIST(list, INT_INTOBJ(pos)) : ISBB_LIST( list, pos)) ? True : False) #define C_UNB_LIST( list, pos) \ - if (IS_INTOBJ(pos)) UNB_LIST(list, INT_INTOBJ(pos)); else UNBB_LIST(list, pos); + if (IS_POS_INTOBJ(pos)) UNB_LIST(list, INT_INTOBJ(pos)); else UNBB_LIST(list, pos); extern void AddList ( Obj list, diff --git a/src/funcs.c b/src/funcs.c index 8ac698a695..10382bd8e1 100644 --- a/src/funcs.c +++ b/src/funcs.c @@ -1156,7 +1156,9 @@ Obj DoPartialUnWrapFunc(Obj func, Obj args) { Obj argx; - named = ((UInt)-NARG_FUNC(func))-1; + + CHECK_RECURSION_BEFORE + named = ((UInt)-NARG_FUNC(func))-1; len = LEN_PLIST(args); if (named > len) { /* Can happen for > 6 arguments */ @@ -1164,7 +1166,6 @@ Obj DoPartialUnWrapFunc(Obj func, Obj args) { return DoOperation2Args(CallFuncListOper, func, argx); } - CHECK_RECURSION_BEFORE SWITCH_TO_NEW_LVARS( func, named+1, NLOC_FUNC(func), oldLvars ); for (i = 1; i <= named; i++) { diff --git a/src/intrprtr.c b/src/intrprtr.c index cc5bdc0ce1..1850d2f2d6 100644 --- a/src/intrprtr.c +++ b/src/intrprtr.c @@ -3161,41 +3161,60 @@ void IntrIsbGVar ( *F IntrAssListLevel() . . . . . interpret assignment to several lists *F IntrAsssListLevel() . . intr multiple assignment to several lists */ -void IntrAssList ( void ) +void IntrAssList ( Int narg ) { Obj list; /* list */ Obj pos; /* position */ - Int p; /* position, as a C integer */ Obj rhs; /* right hand side */ + Obj pos1,pos2; + Obj ixs; + Int i; /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeAssList(); return; } - + if ( IntrCoding > 0 ) { CodeAssList( narg); return; } /* get the right hand side */ rhs = PopObj(); + + switch (narg) { + case 1: - /* get and check the position */ - pos = PopObj(); - if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0) ) { - ErrorQuit( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L ); - } - - /* get the list (checking is done by 'ASS_LIST' or 'ASSB_LIST') */ - list = PopObj(); + /* get the position */ + pos = PopObj(); - if (IS_INTOBJ(pos)) { - p = INT_INTOBJ(pos); + /* get the list (checking is done by 'ASS_LIST' or 'ASSB_LIST') */ + list = PopObj(); - /* assign to the element of the list */ - ASS_LIST( list, p, rhs ); - } else + /* assign to the element of the list */ + if (IS_POS_INTOBJ(pos)) { + ASS_LIST( list, INT_INTOBJ(pos), rhs ); + } else { ASSB_LIST(list, pos, rhs); - + } + break; + + case 2: + pos2 = PopObj(); + pos1 = PopObj(); + list = PopObj(); + + ASS2_LIST(list, pos1, pos2, rhs); + break; + + default: + ixs = NEW_PLIST(T_PLIST, narg); + for (i = narg; i > 0; i--) { + pos = PopObj(); + SET_ELM_PLIST(ixs, i, pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs, narg); + list = PopObj(); + ASSB_LIST(list, ixs, rhs); + } + /* push the right hand side again */ PushObj( rhs ); } @@ -3244,35 +3263,39 @@ void IntrAsssList ( void ) } void IntrAssListLevel ( - UInt level ) + Int narg, + UInt level ) { Obj lists; /* lists, left operand */ Obj pos; /* position, left operand */ Obj rhss; /* right hand sides, right operand */ - + Obj ixs; + Int i; + /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeAssListLevel( level ); return; } + if ( IntrCoding > 0 ) { CodeAssListLevel( narg, level ); return; } /* get right hand sides (checking is done by 'AssListLevel') */ rhss = PopObj(); - /* get and check the position */ - pos = PopObj(); - if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0) ) { - ErrorQuit( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L ); + ixs = NEW_PLIST(T_PLIST, narg); + for (i = narg; i > 0; i--) { + /* get and check the position */ + pos = PopObj(); + SET_ELM_PLIST(ixs, i, pos); + CHANGED_BAG(ixs); } + SET_LEN_PLIST(ixs, narg); /* get lists (if this works, then is nested deep, */ /* checking it is nested +1 deep is done by 'AssListLevel') */ lists = PopObj(); /* assign the right hand sides to the elements of several lists */ - AssListLevel( lists, pos, rhss, level ); + AssListLevel( lists, ixs, rhss, level ); /* push the assigned values again */ PushObj( rhss ); @@ -3313,36 +3336,43 @@ void IntrAsssListLevel ( PushObj( rhss ); } -void IntrUnbList ( void ) +void IntrUnbList ( Int narg ) { Obj list; /* list */ Obj pos; /* position */ - Int p; /* position, as a C integer */ + Obj ixs; + Int i; /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeUnbList(); return; } - - - /* get and check the position */ - pos = PopObj(); - if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0) ) { - ErrorQuit( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L ); - } + if ( IntrCoding > 0 ) { CodeUnbList( narg); return; } - /* get the list (checking is done by 'UNB_LIST') */ - list = PopObj(); - if (IS_INTOBJ(pos)) { - p = INT_INTOBJ(pos); + if (narg == 1) { + /* get and check the position */ + pos = PopObj(); + + /* get the list (checking is done by 'UNB_LIST' or 'UNBB_LIST') */ + list = PopObj(); - /* unbind the element */ - UNB_LIST( list, p ); - } else + /* unbind the element */ + if (IS_POS_INTOBJ(pos)) { + UNB_LIST( list, INT_INTOBJ(pos) ); + } else { UNBB_LIST(list, pos); + } + } else { + ixs = NEW_PLIST(T_PLIST,narg); + for (i = narg; i > 0; i--) { + pos = PopObj(); + SET_ELM_PLIST(ixs, i, pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs, narg); + list = PopObj(); + UNBB_LIST(list, ixs); + } /* push void */ PushVoidObj(); @@ -3356,34 +3386,59 @@ void IntrUnbList ( void ) *F IntrElmListLevel() . . . . . interpret selection of several lists *F IntrElmsListLevel() . . intr multiple selection of several lists */ -void IntrElmList ( void ) +void IntrElmList ( Int narg ) { - Obj elm; /* element, result */ + Obj elm = (Obj) 0; /* element, result */ Obj list; /* list, left operand */ Obj pos; /* position, right operand */ Int p; /* position, as C integer */ + Int i; + Obj ixs; + Obj pos1; + Obj pos2; /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeElmList(); return; } - + if ( IntrCoding > 0 ) { CodeElmList( narg ); return; } + if (narg <= 0) + SyntaxError("This should never happen"); - /* get the position */ - pos = PopObj(); - /* get the list (checking is done by 'ELM_LIST') */ - list = PopObj(); - - - if ( ! IS_INTOBJ(pos) || (p = INT_INTOBJ(pos)) <= 0) { + if (narg == 1) { + /* get the position */ + pos = PopObj(); + /* get the list (checking is done by 'ELM_LIST') */ + list = PopObj(); + + + if ( ! IS_INTOBJ(pos) || (p = INT_INTOBJ(pos)) <= 0) { /* This mostly dispatches to the library */ elm = ELMB_LIST( list, pos); - } else { + } else { /* get the element of the list */ elm = ELM_LIST( list, p ); + } } - + if (narg == 2) { + pos2 = PopObj(); + pos1 = PopObj(); + list = PopObj(); + /* leave open space for a fastpath for 2 */ + elm = ELM2_LIST(list, pos1, pos2); + } + + if (narg > 2) { + ixs = NEW_PLIST(T_PLIST,narg); + for (i = narg; i > 0; i--) { + SET_ELM_PLIST(ixs,i,PopObj()); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs, narg); + list = PopObj(); + elm = ELMB_LIST(list, ixs); + } + /* push the element */ PushObj( elm ); } @@ -3418,32 +3473,43 @@ void IntrElmsList ( void ) PushObj( elms ); } -void IntrElmListLevel ( +void IntrElmListLevel ( Int narg, UInt level ) { Obj lists; /* lists, left operand */ Obj pos; /* position, right operand */ + Obj ixs; + Int i; /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeElmListLevel( level ); return; } + if ( IntrCoding > 0 ) { CodeElmListLevel( narg, level ); return; } - /* get and check the position */ - pos = PopObj(); - if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 )) { - ErrorQuit( - "List Element: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L ); + /* get the positions */ + ixs = NEW_PLIST(T_PLIST, narg); + for (i = narg; i > 0; i--) { + pos = PopObj(); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); } + SET_LEN_PLIST(ixs, narg); + + /* /\* get and check the position *\/ */ + /* pos = PopObj(); */ + /* if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_POS_INTOBJ(pos) )) { */ + /* ErrorQuit( */ + /* "List Element: must be a positive integer (not a %s)", */ + /* (Int)TNAM_OBJ(pos), 0L ); */ + /* } */ /* get lists (if this works, then is nested deep, */ /* checking it is nested +1 deep is done by 'ElmListLevel') */ lists = PopObj(); /* select the elements from several lists (store them in ) */ - ElmListLevel( lists, pos, level ); + ElmListLevel( lists, ixs, level ); /* push the elements */ PushObj( lists ); @@ -3480,38 +3546,46 @@ void IntrElmsListLevel ( PushObj( lists ); } -void IntrIsbList ( void ) +void IntrIsbList ( Int narg ) { Obj isb; /* isbound, result */ Obj list; /* list, left operand */ Obj pos; /* position, right operand */ - Int p; /* position, as C integer */ + Obj ixs; + Int i; /* ignore or code */ if ( IntrReturning > 0 ) { return; } if ( IntrIgnoring > 0 ) { return; } - if ( IntrCoding > 0 ) { CodeIsbList(); return; } + if ( IntrCoding > 0 ) { CodeIsbList(narg); return; } - /* get and check the position */ - pos = PopObj(); - if ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 )) { - ErrorQuit( - "List Element: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L ); + if (narg == 1) { + /* get and check the position */ + pos = PopObj(); + + /* get the list (checking is done by 'ISB_LIST' or 'ISBB_LIST') */ + list = PopObj(); + + /* get the result */ + if (IS_POS_INTOBJ(pos)) { + isb = ISB_LIST( list, INT_INTOBJ(pos) ) ? True : False; + } else { + isb = ISBB_LIST( list, pos) ? True : False; + } + } else { + ixs = NEW_PLIST(T_PLIST,narg); + for (i = narg; i > 0; i--) { + pos = PopObj(); + SET_ELM_PLIST(ixs, i, pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs, narg); + list = PopObj(); + isb = ISBB_LIST(list, ixs) ? True: False; } - - /* get the list (checking is done by 'ISB_LIST') */ - list = PopObj(); - - if (IS_INTOBJ(pos)) { - p = INT_INTOBJ( pos ); - - /* get the result */ - isb = (ISB_LIST( list, p ) ? True : False); - } else - isb = (ISBB_LIST( list, pos) ? True : False); - + + /* push the result */ PushObj( isb ); } @@ -3746,7 +3820,7 @@ void IntrAssPosObj ( void ) /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Assignment: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); @@ -3837,13 +3911,12 @@ void IntrAssPosObjLevel ( /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Assignment: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); } - /* assign the right hand sides to the elements of several lists */ ErrorQuit( "sorry: {}![] not yet implemented", @@ -3899,7 +3972,7 @@ void IntrUnbPosObj ( void ) /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Assignment: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); @@ -3946,7 +4019,7 @@ void IntrElmPosObj ( void ) /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Element: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); @@ -4028,7 +4101,7 @@ void IntrElmPosObjLevel ( /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Element: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); @@ -4095,7 +4168,7 @@ void IntrIsbPosObj ( void ) /* get and check the position */ pos = PopObj(); - if ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + if ( ! IS_POS_INTOBJ(pos) ) { ErrorQuit( "PosObj Element: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L ); diff --git a/src/intrprtr.h b/src/intrprtr.h index 9fc82d99e1..d008c84b5a 100644 --- a/src/intrprtr.h +++ b/src/intrprtr.h @@ -753,17 +753,17 @@ extern void IntrIsbGVar ( *F IntrAssListLevel() . . . . . interpret assignment to several lists *F IntrAsssListLevel() . . intr multiple assignment to several lists */ -extern void IntrAssList ( void ); +extern void IntrAssList ( Int narg ); extern void IntrAsssList ( void ); -extern void IntrAssListLevel ( +extern void IntrAssListLevel ( Int narg, UInt level ); extern void IntrAsssListLevel ( UInt level ); -extern void IntrUnbList ( void ); +extern void IntrUnbList (Int narg ); /**************************************************************************** @@ -773,17 +773,17 @@ extern void IntrUnbList ( void ); *F IntrElmListLevel() . . . . . interpret selection of several lists *F IntrElmsListLevel() . . intr multiple selection of several lists */ -extern void IntrElmList ( void ); +extern void IntrElmList ( Int narg); extern void IntrElmsList ( void ); -extern void IntrElmListLevel ( +extern void IntrElmListLevel ( Int narg, UInt level ); extern void IntrElmsListLevel ( UInt level ); -extern void IntrIsbList ( void ); +extern void IntrIsbList ( Int narg ); /**************************************************************************** diff --git a/src/lists.c b/src/lists.c index b4a21c0133..eeba0e18f0 100644 --- a/src/lists.c +++ b/src/lists.c @@ -48,6 +48,7 @@ #include "integer.h" /* integers */ + /**************************************************************************** ** *F IS_LIST() . . . . . . . . . . . . . . . . . . . is an object a list @@ -89,6 +90,23 @@ Int IsListObject ( return (DoFilter( IsListFilt, obj ) == True); } + +Obj Elm2List(Obj list, Obj pos1, Obj pos2) { + Obj ixs = NEW_PLIST(T_PLIST,2); + SET_ELM_PLIST(ixs,1,pos1); + SET_ELM_PLIST(ixs,2,pos2); + SET_LEN_PLIST(ixs,2); + return ELMB_LIST(list, ixs); +} + +void Ass2List(Obj list, Obj pos1, Obj pos2, Obj obj) { + Obj ixs = NEW_PLIST(T_PLIST,2); + SET_ELM_PLIST(ixs,1,pos1); + SET_ELM_PLIST(ixs,2,pos2); + SET_LEN_PLIST(ixs,2); + ASSB_LIST(list, ixs, obj); +} + /**************************************************************************** ** *F IS_SMALL_LIST() . . . . . . . . . . . . . . . . . . . is an object a list @@ -332,12 +350,15 @@ Int (*IsbvListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); Obj IsbListOper; -Obj IsbListHandler ( +Obj FuncISB_LIST ( Obj self, Obj list, Obj pos ) { - return (ISB_LIST( list, INT_INTOBJ(pos) ) ? True : False); + if (IS_POS_INTOBJ(pos)) + return ISB_LIST( list, INT_INTOBJ(pos) ) ? True : False; + else + return ISBB_LIST( list, pos ) ? True : False; } Int IsbListError ( @@ -355,64 +376,14 @@ Int IsbListObject ( Obj list, Int pos ) { - return (DoOperation2Args( IsbListOper, list, INTOBJ_INT(pos) ) == True); -} - -/**************************************************************************** -** -*F ISBB_LIST(,,) . . . . . isbound for an element to a list -*V IsbbListFuncs[] . . . . . . . . . . table of isbound functions -*F IsbbListError(,,) . . . . . . . error isbound function -** -** 'ISBB_LIST' only calls the function pointed to by 'IsbbListFuncs[]', -** passing , , and as arguments. If is not the type -** of a list, then 'IsbbListFuncs[]' points to 'IsbbListError', which -** just signals an error. -** -** 'ISBB_LIST' is defined in the declaration part of this package as follows. -** -#define ISBB_LIST(list,pos,obj) \ - ((*IsbbListFuncs[TNUM_OBJ(list)])(list,pos,obj)) -*/ -Int (*IsbbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos); - -Obj FuncISBB_LIST ( - Obj self, - Obj list, - Obj pos) -{ - return ISBB_LIST( list, pos ) ? True: False; -} - -Int IsbbListError ( - Obj list, - Obj pos ) -{ - list = ErrorReturnObj( - "Isbound: must be a list (not a %s)", - (Int)TNAM_OBJ(list), 0L, - "you can replace via 'return ;'" ); - return ISBB_LIST( list, pos ); + return DoOperation2Args( IsbListOper, list, INTOBJ_INT(pos) ) == True; } -Int IsbbListInternal ( - Obj list, - Obj pos) -{ - return 0; -} - - -/**************************************************************************** -** -*F IsbbListObject( , , ) . . . . . . . assign to list object -*/ - -Int IsbbListObject ( +Int ISBB_LIST ( Obj list, Obj pos ) { - return DoOperation2Args( IsbListOper, list, pos ) == True ? 1 : 0; + return DoOperation2Args( IsbListOper, list, pos ) == True; } @@ -535,23 +506,6 @@ Obj FuncELM0_LIST ( */ Obj (*ElmListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); -/**************************************************************************** -** -*V ElmbListFuncs[] . . . . . . . . . . . table of selection functions -** -** 'ELMB_LIST' returns the element at the position in the list . -** An error is signalled if is not a list, if is larger than -** the length of , or if has no assigned object at . It -** is the responsibility of the caller to ensure that is a positive -** integer. -** -** 'ELMB_LIST' only calls the functions pointed to by 'ElmbListFuncs[]' -** passing and as arguments. If is not the type of a -** list, then 'ElmbListFuncs[]' points to 'ElmbListError', which signals -** the error. -*/ -Obj (*ElmbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos ); - /**************************************************************************** ** @@ -617,67 +571,6 @@ Obj ElmListObject ( return elm; } -#if 0 -/**************************************************************************** -** -*F ElmbListError( , ) . . . . . . . . . . . . . . . error message -*/ -Obj ElmbListError ( - Obj list, - Obj pos ) -{ - list = ErrorReturnObj( - "List Element: must be a list (not a %s)", - (Int)TNAM_OBJ(list), 0L, - "you can replace via 'return ;'" ); - return ELMB_LIST( list, pos ); -} - -/**************************************************************************** -** -*F ElmbListInternal( , ) . . . . . . . . . . . . . error message -*/ -Obj ElmbListInternal ( - Obj list, - Obj pos ) -{ - do { - pos = ErrorReturnObj( - "List Element: an internal list cannot have an element in such a position", - 0L, 0L, - "you can supply a new position via 'return ;'" ); - } while (!IS_INTOBJ(pos) || INT_INTOBJ(pos) < 0); - return ELM_LIST( list, INT_INTOBJ(pos) ); -} - - -/**************************************************************************** -** -*F ElmbListObject( , . . . . . . . select an element from a list -** -** `ElmbListObject' is the `ELMB_LIST', function -** for objects. 'ElmbListObjects' selects the element at position of -** list object . It is the responsibility of the caller to ensure -** that is a positive integer. The methods have to signal an error if -** is larger than the length of or if the entry is not bound. -*/ - -Obj ElmbListObject ( - Obj list, - Obj pos ) -{ - Obj elm; - - elm = DoOperation2Args( ElmListOper, list, pos ); - while ( elm == 0 ) { - elm = ErrorReturnObj( - "List access method must return a value", 0L, 0L, - "you can supply a value via 'return ;'" ); - } - return elm; -} - -#endif Obj ELMB_LIST(Obj list, Obj pos) { Obj elm; @@ -978,7 +871,10 @@ Obj FuncUNB_LIST ( Obj list, Obj pos ) { - UNB_LIST( list, INT_INTOBJ(pos) ); + if (IS_POS_INTOBJ(pos)) + UNB_LIST( list, INT_INTOBJ(pos) ); + else + UNBB_LIST( list, pos ); return 0; } @@ -1008,59 +904,7 @@ void UnbListObject ( DoOperation2Args( UnbListOper, list, INTOBJ_INT(pos) ); } -/**************************************************************************** -** -*F UNBB_LIST(,,) . . . . . . . . unbind an element to a list -*V UnbbListFuncs[] . . . . . . . . . . . table of unbinding functions -*F UnbbListError(,,) . . . . . . . .error unbinding function -** -** 'UNBB_LIST' only calls the function pointed to by 'UnbbListFuncs[]', -** passing , , and as arguments. If is not the type -** of a list, then 'UnbbListFuncs[]' points to 'UnbbListError', which -** just signals an error. -** -** 'UNBB_LIST' is defined in the declaration part of this package as follows. -** -#define UNBB_LIST(list,pos,obj) \ - ((*UnbbListFuncs[TNUM_OBJ(list)])(list,pos,obj)) -*/ -void (*UnbbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos ); - -Obj FuncUNBB_LIST ( - Obj self, - Obj list, - Obj pos ) -{ - UNBB_LIST( list, pos ); - return 0; -} - -void UnbbListError ( - Obj list, - Obj pos ) -{ - list = ErrorReturnObj( - "List Unbindment: must be a list (not a %s)", - (Int)TNAM_OBJ(list), 0L, - "you can replace via 'return ;'" ); - UNBB_LIST( list, pos ); -} - -void UnbbListInternal ( - Obj list, - Obj pos) -{ - /* large positions are already unbound */ - return; -} - - -/**************************************************************************** -** -*F UnbbListObject( , , ) . . . . . . . unbind list object -*/ - -void UnbbListObject ( +void UNBB_LIST ( Obj list, Obj pos ) { @@ -1085,13 +929,18 @@ void UnbbListObject ( */ void (*AssListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos, Obj obj ); +Obj AssListOper; + Obj FuncASS_LIST ( Obj self, Obj list, Obj pos, Obj obj ) { - ASS_LIST( list, INT_INTOBJ(pos), obj ); + if (IS_INTOBJ(pos)) + ASS_LIST( list, INT_INTOBJ(pos), obj ); + else + ASSB_LIST(list, pos, obj); return 0; } @@ -1121,7 +970,6 @@ void AssListDefault ( ** *F AssListObject( , , ) . . . . . . . assign to list object */ -Obj AssListOper; void AssListObject ( Obj list, @@ -1130,66 +978,8 @@ void AssListObject ( { DoOperation3Args( AssListOper, list, INTOBJ_INT(pos), obj ); } -/**************************************************************************** -** -*F ASSB_LIST(,,) . . . . . . . . assign an element to a list -*V AssbListFuncs[] . . . . . . . . . . . table of assignment functions -*F AssbListError(,,) . . . . . . . error assignment function -** -** 'ASSB_LIST' only calls the function pointed to by 'AssbListFuncs[]', -** passing , , and as arguments. If is not the type -** of a list, then 'AssbListFuncs[]' points to 'AssbListError', which -** just signals an error. -** -** 'ASSB_LIST' is defined in the declaration part of this package as follows. -** -#define ASSB_LIST(list,pos,obj) \ - ((*AssbListFuncs[TNUM_OBJ(list)])(list,pos,obj)) -*/ -void (*AssbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos, Obj obj ); -Obj FuncASSB_LIST ( - Obj self, - Obj list, - Obj pos, - Obj obj ) -{ - ASSB_LIST( list, pos, obj ); - return 0; -} - -void AssbListError ( - Obj list, - Obj pos, - Obj obj ) -{ - list = ErrorReturnObj( - "List Assignment: must be a list (not a %s)", - (Int)TNAM_OBJ(list), 0L, - "you can replace via 'return ;'" ); - ASSB_LIST( list, pos, obj ); -} - -void AssbListInternal ( - Obj list, - Obj pos, - Obj obj ) -{ - do { - pos = ErrorReturnObj( "List assignment: you cannot assign to such a large position in an internal list", - 0, 0, - "you can supply a new position via 'return ;'" ); - } while (!IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0); - ASS_LIST(list, INT_INTOBJ(pos), obj); -} - - -/**************************************************************************** -** -*F AssbListObject( , , ) . . . . . . . assign to list object -*/ - -void AssbListObject ( +void ASSB_LIST ( Obj list, Obj pos, Obj obj ) @@ -1198,6 +988,7 @@ void AssbListObject ( } + /**************************************************************************** ** *F ASSS_LIST(,,) . . . . assign several elements to a list @@ -1878,13 +1669,17 @@ Obj FuncPOS_LIST_DEFAULT ( */ void ElmListLevel ( Obj lists, - Obj pos, + Obj ixs, Int level ) { Int len; /* length of */ Obj list; /* one list from */ Obj elm; /* selected element from */ Int i; /* loop variable */ + Obj pos; + Obj pos1; + Obj pos2; + /* if is one, perform the replacements */ if ( level == 1 ) { @@ -1897,10 +1692,25 @@ void ElmListLevel ( list = ELM_PLIST( lists, i ); /* select the element */ - if (IS_INTOBJ(pos)) - elm = ELM_LIST( list, INT_INTOBJ(pos) ); - else - elm = ELMB_LIST(list, pos); + switch(LEN_PLIST(ixs)) { + case 1: + pos = ELM_PLIST(ixs,1); + if (IS_INTOBJ(pos)) + elm = ELM_LIST( list, INT_INTOBJ(pos) ); + else + elm = ELMB_LIST(list, pos); + break; + + case 2: + pos1 = ELM_PLIST(ixs,1); + pos2 = ELM_PLIST(ixs,2); + elm = ELM2_LIST(list, pos1, pos2); + break; + + default: + elm = ELMB_LIST(list, ixs); + + } /* replace the list with the element */ SET_ELM_PLIST( lists, i, elm ); @@ -1924,7 +1734,7 @@ void ElmListLevel ( list = ELM_PLIST( lists, i ); /* recurse */ - ElmListLevel( list, pos, level-1 ); + ElmListLevel( list, ixs, level-1 ); } @@ -2009,7 +1819,7 @@ void ElmsListLevel ( /**************************************************************************** ** -*F AssListLevel(,,,) . . . . . . . . . . . . . . . +*F AssListLevel(,,,) . . . . . . . . . . . . . . . *F . . . . . . . . . . . . . assign an element to several lists in parallel ** ** 'AssListLevel' either assigns an element to all lists in parallel if @@ -2017,7 +1827,7 @@ void ElmsListLevel ( */ void AssListLevel ( Obj lists, - Obj pos, + Obj ixs, Obj objs, Int level ) { @@ -2025,6 +1835,7 @@ void AssListLevel ( Obj list; /* one list of */ Obj obj; /* one value from */ Int i; /* loop variable */ + Obj pos,pos1,pos2; /* check */ while ( ! IS_DENSE_LIST(objs) || LEN_LIST(lists) != LEN_LIST(objs) ) { @@ -2055,11 +1866,25 @@ void AssListLevel ( /* select the element to assign */ obj = ELMW_LIST( objs, i ); - /* assign the element */ - if (IS_INTOBJ(pos)) - ASS_LIST( list, INT_INTOBJ(pos), obj ); - else - ASSB_LIST(list, pos, obj); + switch(LEN_PLIST(ixs)) { + case 1: + /* assign the element */ + pos = ELM_PLIST(ixs,1); + if (IS_INTOBJ(pos)) + ASS_LIST( list, INT_INTOBJ(pos), obj ); + else + ASSB_LIST(list, pos, obj); + break; + + case 2: + pos1 = ELM_PLIST(ixs,1); + pos2 = ELM_PLIST(ixs,2); + ASS2_LIST(list, pos1, pos2, obj); + break; + + default: + ASSB_LIST(list, ixs, obj); + } } @@ -2079,7 +1904,7 @@ void AssListLevel ( obj = ELMW_LIST( objs, i ); /* recurse */ - AssListLevel( list, pos, obj, level-1 ); + AssListLevel( list, ixs, obj, level-1 ); } @@ -2592,7 +2417,7 @@ static StructGVarOper GVarOpers [] = { DoOperation0Args, "src/lists.c:POS_LIST" }, { "ISB_LIST", 2, "list, pos", &IsbListOper, - IsbListHandler, "src/lists.c:ISB_LIST" }, + FuncISB_LIST, "src/lists.c:ISB_LIST" }, { "ELM0_LIST", 2, "list, pos", &Elm0ListOper, FuncELM0_LIST, "src/lists.c:ELM0_LIST" }, @@ -2739,19 +2564,6 @@ static Int InitKernel ( IsbListFuncs[ T_SINGULAR ] = IsbListObject; IsbvListFuncs[ T_SINGULAR ] = IsbListObject; - /* make and install the 'ISBB_LIST' operation */ - for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { - IsbbListFuncs[ type ] = IsbbListError; - } - - for (type = FIRST_LIST_TNUM; type <= LAST_LIST_TNUM; type++ ) { - IsbbListFuncs[ type ] = IsbbListInternal; - } - - for ( type = FIRST_EXTERNAL_TNUM; type <= LAST_EXTERNAL_TNUM; type++ ) { - IsbbListFuncs[ type ] = IsbbListObject; - } - IsbbListFuncs[ T_SINGULAR ] = IsbbListObject; /* make and install the 'ELM0_LIST' operation */ for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { @@ -2781,20 +2593,6 @@ static Int InitKernel ( ElmvListFuncs[ T_SINGULAR ] = ElmListObject; ElmwListFuncs[ T_SINGULAR ] = ElmListObject; - /* make and install the 'ELMB_LIST' operation - for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { - ElmbListFuncs[ type ] = ElmbListError; - } - - for (type = FIRST_LIST_TNUM; type <= LAST_LIST_TNUM; type++ ) { - ElmbListFuncs[ type ] = ElmbListInternal; - } - - for ( type = FIRST_EXTERNAL_TNUM; type <= LAST_EXTERNAL_TNUM; type++ ) { - ElmbListFuncs[ type ] = ElmbListObject; - } - - */ /* make and install the 'ELMS_LIST' operation */ for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { @@ -2821,19 +2619,6 @@ static Int InitKernel ( } UnbListFuncs[ T_SINGULAR ] = UnbListObject; - /* make and install the 'UNBB_LIST' operation */ - for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { - UnbbListFuncs[ type ] = UnbbListError; - } - - for (type = FIRST_LIST_TNUM; type <= LAST_LIST_TNUM; type++ ) { - UnbbListFuncs[ type ] = UnbbListInternal; - } - - for ( type = FIRST_EXTERNAL_TNUM; type <= LAST_EXTERNAL_TNUM; type++ ) { - UnbbListFuncs[ type ] = UnbbListObject; - } - UnbbListFuncs[ T_SINGULAR ] = UnbbListObject; /* make and install the 'ASS_LIST' operation */ for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { @@ -2848,19 +2633,6 @@ static Int InitKernel ( AssListFuncs[ T_SINGULAR ] = AssListObject; - /* make and install the 'ASSB_LIST' operation */ - for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { - AssbListFuncs[ type ] = AssbListError; - } - - for (type = FIRST_LIST_TNUM; type <= LAST_LIST_TNUM; type++ ) { - AssbListFuncs[ type ] = AssbListInternal; - } - - for ( type = FIRST_EXTERNAL_TNUM; type <= LAST_EXTERNAL_TNUM; type++ ) { - AssbListFuncs[ type ] = AssbListObject; - } - AssbListFuncs[ T_SINGULAR ] = AssbListObject; /* make and install the 'ASSS_LIST' operation */ for ( type = FIRST_REAL_TNUM; type <= LAST_REAL_TNUM; type++ ) { diff --git a/src/lists.h b/src/lists.h index 812b444fec..9149d5db33 100644 --- a/src/lists.h +++ b/src/lists.h @@ -140,11 +140,7 @@ extern Int (*IsbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); extern Int (*IsbvListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); -#define ISBB_LIST(list,pos) \ - ((*IsbbListFuncs[TNUM_OBJ(list)])(list,pos)) - -extern Int (*IsbbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos ); - +extern Int ISBB_LIST( Obj list, Obj pos ); /**************************************************************************** @@ -221,6 +217,7 @@ extern Obj (*ElmListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); /**************************************************************************** ** *F ELM_LIST( , ) . . . . . . . . . select an element from a list +*F ELMB_LIST( , ) . . . . . . . . . select an element from a list ** ** 'ELM_LIST' returns the element at the position in the list . ** An error is signalled if is not a list, if is larger than @@ -232,47 +229,26 @@ extern Obj (*ElmListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); ** call them with arguments that have side effects. ** ** The difference between ELM_LIST and ELMB_LIST is that ELMB_LIST accepts -** an object as the second argument (which should be a positive large integer. +** an object as the second argument ** It is intended as an interface for access to elements of large external ** lists, on the rare occasions when the kernel needs to do this. */ #define ELM_LIST(list,pos) ((*ElmListFuncs[TNUM_OBJ(list)])(list,pos)) -/**************************************************************************** -** -*V ElmbListFuncs[ ] . . . . . . . . . . table of selection functions -** -** A package implementing a list type may provide a function for -** 'ELMB_LIST' and install it in 'ElmbListFuncs[]'. This function must -** signal an error if is larger than the length of or if -** has no assigned object at . - -extern Obj (*ElmbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos ); - -*/ +extern Obj ELMB_LIST( Obj list, Obj pos ); /**************************************************************************** ** -*F ELMB_LIST( , ) . . . . . . . . . select an element from a list -** -** 'ELM_LIST' returns the element at the position in the list . -** An error is signalled if is not a list, if is larger than -** the length of , or if has no assigned object at . It -** is the responsibility of the caller to ensure that is a positive -** integer. -** -** Note that 'ELM_LIST', 'ELMV_LIST', and 'ELMW_LIST' are macros, so do not -** call them with arguments that have side effects. -** -** The difference between ELM_LIST and ELMB_LIST is that ELMB_LIST accepts -** an object as the second argument (which should be a positive large integer. -** It is intended as an interface for access to elements of large external -** lists, on the rare occasions when the kernel needs to do this. +*F ELM2_LIST( , , ) . . . . select an element from a list */ -extern Obj ELMB_LIST( Obj list, Obj pos); +extern Obj Elm2List(Obj list, Obj pos1, Obj pos2); + +#define ELM2_LIST(list, pos1, pos2) Elm2List(list, pos1, pos2) +extern void Ass2List(Obj list, Obj pos1, Obj pos2, Obj obj); +#define ASS2_LIST(list, pos1, pos2, obj) Ass2List(list, pos1, pos2, obj) /**************************************************************************** @@ -415,12 +391,10 @@ extern void ElmsListLevelCheck ( extern void (*UnbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos ); -#define UNBB_LIST(list,pos) \ - ((*UnbbListFuncs[TNUM_OBJ(list)])(list,pos)) +extern void UNBB_LIST( Obj list, Obj pos ); -extern void (*UnbbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos ); +extern void UnbListDefault( Obj list, Int pos ); -extern void UnbListDefault ( Obj list, Int pos ); /**************************************************************************** ** @@ -446,29 +420,7 @@ extern void UnbListDefault ( Obj list, Int pos ); extern void (*AssListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Int pos, Obj obj ); -/**************************************************************************** -** -*F ASSB_LIST(,,) . . . . . . . . assign an element to a list -*V AssbListFuncs[] . . . . . . . . . . . table of assignment functions -** -** 'ASSB_LIST' assigns the object to the list at position . -** Note that the assignment may change the length or the representation of -** . An error is signalled if is not a list. It is the -** responsibility of the caller to ensure that is a positive integer, -** and that is not 0. -** -** Note that 'ASSB_LIST' is a macro, so do not call it with arguments that -** have side effects. -** -** A package implementing a list type must provide such a function -** and install it in 'AssbListFuncs[]'. This function must extend -** if is larger than the length of and must also change -** the representation of to that of a plain list if necessary. -*/ -#define ASSB_LIST(list,pos,obj) \ - ((*AssbListFuncs[TNUM_OBJ(list)])(list,pos,obj)) - -extern void (*AssbListFuncs[LAST_REAL_TNUM+1]) ( Obj list, Obj pos, Obj obj ); +extern void ASSB_LIST( Obj list, Obj pos, Obj obj ); /**************************************************************************** diff --git a/src/read.c b/src/read.c index 970e819269..e8ff0e9f77 100644 --- a/src/read.c +++ b/src/read.c @@ -180,7 +180,7 @@ UInt GlobalComesFromEnclosingForLoop (UInt var) ** := a|b|..|z|A|B|..|Z { a|b|..|z|A|B|..|Z|0|..|9|_ } ** ** := -** | '[' ]' +** | '[' [,]* ']' ** | '{' '}' ** | '.' ** | '(' [ { ',' } ] [':' [ ]] ')' @@ -397,8 +397,8 @@ void ReadCallVarAss ( else if ( type == 'h' ) { IntrRefHVar( var ); level=0; } else if ( type == 'd' ) { IntrRefDVar( var, nest0 - 1 ); level=0; } else if ( type == 'g' ) { IntrRefGVar( var ); level=0; } - else if ( type == '[' ) { IntrElmList(); } - else if ( type == ']' ) { IntrElmListLevel( level ); } + else if ( type == '[' ) { IntrElmList(narg); } + else if ( type == ']' ) { IntrElmListLevel( level, narg ); } else if ( type == '{' ) { IntrElmsList(); level++; } else if ( type == '}' ) { IntrElmsListLevel( level ); level++; } else if ( type == '<' ) { IntrElmPosObj(); } @@ -414,8 +414,15 @@ void ReadCallVarAss ( /* '[' ']' list selector */ if ( Symbol == S_LBRACK ) { + Match( S_LBRACK, "[", follow ); - ReadExpr( S_RBRACK|follow, 'r' ); + ReadExpr( S_COMMA|S_RBRACK|follow, 'r' ); + narg = 1; + while (Symbol == S_COMMA) { + Match(S_COMMA,",", follow|S_RBRACK); + ReadExpr(S_COMMA|S_RBRACK|follow, 'r' ); + narg++; + } Match( S_RBRACK, "]", follow ); type = (level == 0 ? '[' : ']'); } @@ -519,8 +526,8 @@ void ReadCallVarAss ( else if ( type == 'h' ) { IntrRefHVar( var ); } else if ( type == 'd' ) { IntrRefDVar( var, nest0 - 1 ); } else if ( type == 'g' ) { IntrRefGVar( var ); } - else if ( type == '[' ) { IntrElmList(); } - else if ( type == ']' ) { IntrElmListLevel( level ); } + else if ( type == '[' ) { IntrElmList(narg); } + else if ( type == ']' ) { IntrElmListLevel( narg, level ); } else if ( type == '{' ) { IntrElmsList(); } else if ( type == '}' ) { IntrElmsListLevel( level ); } else if ( type == '<' ) { IntrElmPosObj(); } @@ -556,8 +563,8 @@ void ReadCallVarAss ( else if ( type == 'h' ) { IntrAssHVar( var ); } else if ( type == 'd' ) { IntrAssDVar( var, nest0 - 1 ); } else if ( type == 'g' ) { IntrAssGVar( var ); } - else if ( type == '[' ) { IntrAssList(); } - else if ( type == ']' ) { IntrAssListLevel( level ); } + else if ( type == '[' ) { IntrAssList( narg ); } + else if ( type == ']' ) { IntrAssListLevel( narg, level ); } else if ( type == '{' ) { IntrAsssList(); } else if ( type == '}' ) { IntrAsssListLevel( level ); } else if ( type == '<' ) { IntrAssPosObj(); } @@ -582,7 +589,7 @@ void ReadCallVarAss ( else if ( type == 'h' ) { IntrUnbHVar( var ); } else if ( type == 'd' ) { IntrUnbDVar( var, nest0 - 1 ); } else if ( type == 'g' ) { IntrUnbGVar( var ); } - else if ( type == '[' ) { IntrUnbList(); } + else if ( type == '[' ) { IntrUnbList( narg ); } else if ( type == '<' ) { IntrUnbPosObj(); } else if ( type == '.' ) { IntrUnbRecName( rnam ); } else if ( type == ':' ) { IntrUnbRecExpr(); } @@ -599,7 +606,7 @@ void ReadCallVarAss ( else if ( type == 'h' ) { IntrIsbHVar( var ); } else if ( type == 'd' ) { IntrIsbDVar( var, nest0 - 1 ); } else if ( type == 'g' ) { IntrIsbGVar( var ); } - else if ( type == '[' ) { IntrIsbList(); } + else if ( type == '[' ) { IntrIsbList( narg ); } else if ( type == '<' ) { IntrIsbPosObj(); } else if ( type == '.' ) { IntrIsbRecName( rnam ); } else if ( type == ':' ) { IntrIsbRecExpr(); } diff --git a/src/vars.c b/src/vars.c index cbfa7b5273..dfcf0efea9 100644 --- a/src/vars.c +++ b/src/vars.c @@ -1138,41 +1138,103 @@ UInt ExecAssList ( SET_BRK_CURR_STAT( stat ); list = EVAL_EXPR( ADDR_STAT(stat)[0] ); - /* evaluate and check the position */ + /* evaluate the position */ pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); - while ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 )) { - pos = ErrorReturnObj( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L, - "you can replace via 'return ;'" ); - } /* evaluate the right hand side */ rhs = EVAL_EXPR( ADDR_STAT(stat)[2] ); - if (IS_INTOBJ(pos)) - { - p = INT_INTOBJ(pos); - - /* special case for plain list */ - if ( TNUM_OBJ(list) == T_PLIST ) { + if (IS_POS_INTOBJ(pos)) { + p = INT_INTOBJ(pos); + + /* special case for plain list */ + if ( TNUM_OBJ(list) == T_PLIST ) { if ( LEN_PLIST(list) < p ) { - GROW_PLIST( list, p ); - SET_LEN_PLIST( list, p ); + GROW_PLIST( list, p ); + SET_LEN_PLIST( list, p ); } SET_ELM_PLIST( list, p, rhs ); CHANGED_BAG( list ); - } - - /* generic case */ - else - { - ASS_LIST( list, p, rhs ); - } } - else - ASSB_LIST(list, pos, rhs); - + + /* generic case */ + else { + ASS_LIST( list, p, rhs ); + } + } else { + ASSB_LIST(list, pos, rhs); + } + + /* return 0 (to indicate that no leave-statement was executed) */ + return 0; +} +/**************************************************************************** +** +*F ExecAss2List() . . . . . . . . . . . assign to an element of a list +** +** 'ExexAss2List' executes the list assignment statement of the form +** '[,] := ;'. +*/ +UInt ExecAss2List ( + Expr stat ) +{ + Obj list; /* list, left operand */ + Obj pos1; /* position, left operand */ + Obj pos2; /* position, left operand */ + Obj rhs; /* right hand side, right operand */ + + /* evaluate the list (checking is done by 'ASS_LIST') */ + SET_BRK_CURR_STAT( stat ); + list = EVAL_EXPR( ADDR_STAT(stat)[0] ); + + /* evaluate the position */ + pos1 = EVAL_EXPR( ADDR_STAT(stat)[1] ); + pos2 = EVAL_EXPR( ADDR_STAT(stat)[2] ); + + /* evaluate the right hand side */ + rhs = EVAL_EXPR( ADDR_STAT(stat)[3] ); + + ASS2_LIST( list, pos1, pos2, rhs ); + + /* return 0 (to indicate that no leave-statement was executed) */ + return 0; +} +/**************************************************************************** +** +*F ExecAssXList() . . . . . . . . . . . assign to an element of a list +** +** 'ExexAssXList' executes the list assignment statement of the form +** '[,,[,]*] := ;'. +*/ +UInt ExecAssXList ( + Expr stat ) +{ + Obj list; /* list, left operand */ + Obj pos; /* position, left operand */ + Obj rhs; /* right hand side, right operand */ + Obj ixs; + Int i; + Int narg; + + /* evaluate the list (checking is done by 'ASS_LIST') */ + SET_BRK_CURR_STAT( stat ); + list = EVAL_EXPR( ADDR_STAT(stat)[0] ); + + narg = SIZE_STAT(stat)/sizeof(Stat) - 2; + ixs = NEW_PLIST(T_PLIST,narg); + + for (i = 1; i <= narg; i++) { + /* evaluate the position */ + pos = EVAL_EXPR( ADDR_STAT(stat)[i] ); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs,narg); + + /* evaluate the right hand side */ + rhs = EVAL_EXPR( ADDR_STAT(stat)[2] ); + + ASSB_LIST(list, ixs, rhs); /* return 0 (to indicate that no leave-statement was executed) */ return 0; @@ -1253,29 +1315,30 @@ UInt ExecAssListLevel ( Obj pos; /* position, left operand */ Obj rhss; /* right hand sides, right operand */ Int level; /* level */ + Int narg,i; + Obj ixs; /* evaluate lists (if this works, then is nested deep, */ /* checking it is nested +1 deep is done by 'AssListLevel') */ SET_BRK_CURR_STAT( stat ); lists = EVAL_EXPR( ADDR_STAT(stat)[0] ); - - /* evaluate and check the position */ - pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); - while ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0) ) { - pos = ErrorReturnObj( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L, - "you can replace via 'return ;'" ); + narg = SIZE_STAT(stat)/sizeof(Stat) -3; + ixs = NEW_PLIST(T_PLIST, narg); + for (i = 1; i <= narg; i++) { + pos = EVAL_EXPR(ADDR_STAT(stat)[i]); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); } + SET_LEN_PLIST(ixs, narg); /* evaluate right hand sides (checking is done by 'AssListLevel') */ - rhss = EVAL_EXPR( ADDR_STAT(stat)[2] ); - + rhss = EVAL_EXPR( ADDR_STAT(stat)[narg+1] ); + /* get the level */ - level = (Int)(ADDR_STAT(stat)[3]); + level = (Int)(ADDR_STAT(stat)[narg+2]); /* assign the right hand sides to the elements of several lists */ - AssListLevel( lists, pos, rhss, level ); + AssListLevel( lists, ixs, rhss, level ); /* return 0 (to indicate that no leave-statement was executed) */ return 0; @@ -1344,24 +1407,34 @@ UInt ExecUnbList ( { Obj list; /* list, left operand */ Obj pos; /* position, left operand */ - Int p; /* position, as a C integer */ + Obj ixs; + Int narg; + Int i; /* evaluate the list (checking is done by 'LEN_LIST') */ SET_BRK_CURR_STAT( stat ); list = EVAL_EXPR( ADDR_STAT(stat)[0] ); - - /* evaluate and check the position */ - pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); - while ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { - pos = ErrorReturnObj( - "List Assignment: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L, - "you can replace via 'return ;'" ); + narg = SIZE_STAT(stat)/sizeof(Stat) - 1; + if (narg == 1) { + pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); + /* unbind the element */ + if (IS_POS_INTOBJ(pos)) { + UNB_LIST( list, INT_INTOBJ(pos) ); + } else { + UNBB_LIST( list, pos ); + } + } else { + ixs = NEW_PLIST(T_PLIST, narg); + for (i = 1; i <= narg; i++) { + /* evaluate the position */ + pos = EVAL_EXPR( ADDR_STAT(stat)[i] ); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs, narg); + UNBB_LIST(list, ixs); } - p = INT_INTOBJ(pos); - - /* unbind the element */ - UNB_LIST( list, p ); + /* return 0 (to indicate that no leave-statement was executed) */ return 0; @@ -1390,29 +1463,93 @@ Obj EvalElmList ( pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */ + if (IS_POS_INTOBJ(pos)) { + p = INT_INTOBJ( pos ); - if (IS_INTOBJ(pos) && (p = INT_INTOBJ( pos )) > 0) - { - - /* special case for plain lists (use generic code to signal errors) */ - if ( IS_PLIST( list ) ) - { + /* special case for plain lists (use generic code to signal errors) */ + if ( IS_PLIST( list ) ) { if ( LEN_PLIST(list) < p ) { - return ELM_LIST( list, p ); + return ELM_LIST( list, p ); } elm = ELM_PLIST( list, p ); if ( elm == 0 ) { - return ELM_LIST( list, p ); + return ELM_LIST( list, p ); } - } - /* generic case */ - else - { + } + /* generic case */ + else { elm = ELM_LIST( list, p ); - } - } - else - elm = ELMB_LIST(list, pos); + } + } else { + elm = ELMB_LIST(list, pos); + } + + /* return the element */ + return elm; +} + +/**************************************************************************** +** +*F EvalElm2List() . . . . . . . . . . . . select an element of a list +** +** 'EvalElm2List' evaluates the list element expression of the form +** '[,]'. +*/ +Obj EvalElm2List ( + Expr expr ) +{ + Obj elm; /* element, result */ + Obj list; /* list, left operand */ + Obj pos1; /* position, right operand */ + Obj pos2; /* position, right operand */ + + /* evaluate the list (checking is done by 'ELM2_LIST') */ + list = EVAL_EXPR( ADDR_EXPR(expr)[0] ); + + /* evaluate and check the positions */ + pos1 = EVAL_EXPR( ADDR_EXPR(expr)[1] ); + pos2 = EVAL_EXPR( ADDR_EXPR(expr)[2] ); + + elm = ELM2_LIST(list, pos1, pos2); + + + /* return the element */ + return elm; +} + +/**************************************************************************** +** +*F EvalElm2List() . . . . . . . . . . . . select an element of a list +** +** 'EvalElm2List' evaluates the list element expression of the form +** '[,,,....]'. +*/ +Obj EvalElmXList ( + Expr expr ) +{ + Obj elm; /* element, result */ + Obj list; /* list, left operand */ + Obj pos; /* position, right operand */ + Obj ixs; + Int narg; + Int i; + + + /* evaluate the list (checking is done by 'ELM2_LIST') */ + list = EVAL_EXPR( ADDR_EXPR(expr)[0] ); + + /* evaluate and check the positions */ + narg = SIZE_EXPR(expr)/sizeof(Expr) -1; + ixs = NEW_PLIST(T_PLIST,narg); + for (i = 1; i <= narg; i++) { + pos = EVAL_EXPR( ADDR_EXPR(expr)[i] ); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); + } + SET_LEN_PLIST(ixs,narg); + + elm = ELMB_LIST(list,ixs); + /* return the element */ return elm; } @@ -1470,25 +1607,27 @@ Obj EvalElmListLevel ( { Obj lists; /* lists, left operand */ Obj pos; /* position, right operand */ + Obj ixs; Int level; /* level */ + Int narg; + Int i; /* evaluate lists (if this works, then is nested deep, */ /* checking it is nested +1 deep is done by 'ElmListLevel') */ lists = EVAL_EXPR( ADDR_EXPR(expr)[0] ); - - /* evaluate and check the position */ - pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); - while ( TNUM_OBJ(pos) != T_INTPOS && (! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 )) { - pos = ErrorReturnObj( - "List Element: must be a positive integer (not a %s)", - (Int)TNAM_OBJ(pos), 0L, - "you can replace via 'return ;'" ); + narg = SIZE_EXPR(expr)/sizeof(Expr) -2; + ixs = NEW_PLIST(T_PLIST, narg); + for (i = 1; i <= narg; i++) { + pos = EVAL_EXPR( ADDR_EXPR(expr)[i]); + SET_ELM_PLIST(ixs, i, pos); + CHANGED_BAG(ixs); } + SET_LEN_PLIST(ixs, narg); /* get the level */ - level = (Int)(ADDR_EXPR(expr)[2]); + level = (Int)(ADDR_EXPR(expr)[narg+1]); /* select the elements from several lists (store them in ) */ - ElmListLevel( lists, pos, level ); + ElmListLevel( lists, ixs, level ); /* return the elements */ return lists; @@ -1552,20 +1691,31 @@ Obj EvalIsbList ( { Obj list; /* list, left operand */ Obj pos; /* position, right operand */ - Int p; /* position, as C integer */ + Obj ixs; + Int narg, i; /* evaluate the list (checking is done by 'ISB_LIST') */ list = EVAL_EXPR( ADDR_EXPR(expr)[0] ); - - /* evaluate and check the position */ - pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); - if (IS_INTOBJ(pos)) - { - p = INT_INTOBJ( pos ); - return (ISB_LIST( list, p ) ? True : False); + narg = SIZE_EXPR(expr)/sizeof(Expr) -1; + if (narg == 1) { + /* evaluate and check the position */ + pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); + + if (IS_POS_INTOBJ(pos)) + return ISB_LIST( list, INT_INTOBJ(pos) ) ? True : False; + else + return ISBB_LIST(list, pos) ? True : False; + } else { + ixs = NEW_PLIST(T_PLIST, narg); + for (i = 1; i <= narg; i++) { + pos = EVAL_EXPR( ADDR_EXPR(expr)[i] ); + SET_ELM_PLIST(ixs,i,pos); + CHANGED_BAG(ixs); } - else - return ISBB_LIST(list, pos) ? True : False; + SET_LEN_PLIST(ixs, narg); + return ISBB_LIST(list, ixs) ? True : False; + } + } @@ -1591,14 +1741,54 @@ void PrintAssList ( Pr("%2<;",0L,0L); } +void PrintAss2List ( + Stat stat ) +{ + Pr("%4>",0L,0L); + PrintExpr( ADDR_STAT(stat)[0] ); + Pr("%<[",0L,0L); + PrintExpr( ADDR_STAT(stat)[1] ); + Pr("%<, %>",0L,0L); + PrintExpr( ADDR_STAT(stat)[2] ); + Pr("%<]",0L,0L); + Pr("%< %>:= ",0L,0L); + PrintExpr( ADDR_STAT(stat)[3] ); + Pr("%2<;",0L,0L); +} + +void PrintAssXList ( + Stat stat ) +{ + Int narg = SIZE_STAT(stat)/sizeof(stat) - 2; + Int i; + Pr("%4>",0L,0L); + PrintExpr( ADDR_STAT(stat)[0] ); + Pr("%<[",0L,0L); + PrintExpr( ADDR_STAT(stat)[1] ); + for (i = 2; i <= narg; i++) { + Pr("%<, %>",0L,0L); + PrintExpr( ADDR_STAT(stat)[i] ); + } + Pr("%<]",0L,0L); + Pr("%< %>:= ",0L,0L); + PrintExpr( ADDR_STAT(stat)[narg + 1] ); + Pr("%2<;",0L,0L); +} + void PrintUnbList ( Stat stat ) { + Int narg = SIZE_STAT(stat)/sizeof(Stat) -1; + Int i; Pr( "Unbind( ", 0L, 0L ); Pr("%2>",0L,0L); PrintExpr( ADDR_STAT(stat)[0] ); Pr("%<[",0L,0L); PrintExpr( ADDR_STAT(stat)[1] ); + for (i = 2; i <= narg; i++) { + Pr("%<, %>",0L,0L); + PrintExpr(ADDR_STAT(stat)[i]); + } Pr("%<]",0L,0L); Pr( " );", 0L, 0L ); } @@ -1646,14 +1836,65 @@ void PrintElmList ( Pr("%<]",0L,0L); } +void PrintElm2List ( + Expr expr ) +{ + Pr("%2>",0L,0L); + PrintExpr( ADDR_EXPR(expr)[0] ); + Pr("%<[",0L,0L); + PrintExpr( ADDR_EXPR(expr)[1] ); + Pr("%<, %<",0L,0L); + PrintExpr( ADDR_EXPR(expr)[2] ); + Pr("%<]",0L,0L); +} + +void PrintElmXList ( + Expr expr ) +{ + Int i; + Int narg = SIZE_EXPR(expr)/sizeof(Expr) -1 ; + Pr("%2>",0L,0L); + PrintExpr( ADDR_EXPR(expr)[0] ); + Pr("%<[",0L,0L); + PrintExpr( ADDR_EXPR(expr)[1] ); + for (i = 2; i <= narg; i++) { + Pr("%<, %<",0L,0L); + PrintExpr( ADDR_EXPR(expr)[2] ); + } + Pr("%<]",0L,0L); +} + +void PrintElmListLevel ( + Expr expr ) +{ + Int i; + Int narg = SIZE_EXPR(expr)/sizeof(Expr) -2 ; + Pr("%2>",0L,0L); + PrintExpr( ADDR_EXPR(expr)[0] ); + Pr("%<[",0L,0L); + PrintExpr( ADDR_EXPR(expr)[1] ); + for (i = 2; i <= narg; i++) { + Pr("%<, %<",0L,0L); + PrintExpr( ADDR_EXPR(expr)[2] ); + } + Pr("%<]",0L,0L); +} + + void PrintIsbList ( Expr expr ) { + Int narg = SIZE_EXPR(expr)/sizeof(Expr) - 1; + Int i; Pr( "IsBound( ", 0L, 0L ); Pr("%2>",0L,0L); PrintExpr( ADDR_EXPR(expr)[0] ); Pr("%<[",0L,0L); PrintExpr( ADDR_EXPR(expr)[1] ); + for (i = 2; i <= narg; i++) { + Pr("%<, %>", 0L, 0L); + PrintExpr(ADDR_EXPR(expr)[i] ); + } Pr("%<]",0L,0L); Pr( " )", 0L, 0L ); } @@ -2050,7 +2291,7 @@ UInt ExecAssPosObj ( /* evaluate and check the position */ pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); - while ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + while ( ! IS_POS_INTOBJ(pos) ) { pos = ErrorReturnObj( "PosObj Assignment: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L, @@ -2100,7 +2341,7 @@ UInt ExecUnbPosObj ( /* evaluate and check the position */ pos = EVAL_EXPR( ADDR_STAT(stat)[1] ); - while ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + while ( ! IS_POS_INTOBJ(pos) ) { pos = ErrorReturnObj( "PosObj Assignment: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L, @@ -2143,7 +2384,7 @@ Obj EvalElmPosObj ( /* evaluate and check the position */ pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); - while ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + while ( ! IS_POS_INTOBJ(pos) ) { pos = ErrorReturnObj( "PosObj Element: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L, @@ -2198,7 +2439,7 @@ Obj EvalIsbPosObj ( /* evaluate and check the position */ pos = EVAL_EXPR( ADDR_EXPR(expr)[1] ); - while ( ! IS_INTOBJ(pos) || INT_INTOBJ(pos) <= 0 ) { + while ( ! IS_POS_INTOBJ(pos) ) { pos = ErrorReturnObj( "PosObj Element: must be a positive integer (not a %s)", (Int)TNAM_OBJ(pos), 0L, @@ -2959,12 +3200,22 @@ static Int InitKernel ( InstallExecStatFunc( T_ASSS_LIST , ExecAsssList); InstallExecStatFunc( T_ASS_LIST_LEV , ExecAssListLevel); InstallExecStatFunc( T_ASSS_LIST_LEV , ExecAsssListLevel); + InstallExecStatFunc( T_ASS2_LIST , ExecAss2List); + InstallExecStatFunc( T_ASSX_LIST , ExecAssXList); + InstallPrintStatFunc( T_ASS2_LIST , PrintAss2List); + InstallPrintStatFunc( T_ASSX_LIST , PrintAssXList); + InstallExecStatFunc( T_UNB_LIST , ExecUnbList); InstallEvalExprFunc( T_ELM_LIST , EvalElmList); InstallEvalExprFunc( T_ELMS_LIST , EvalElmsList); InstallEvalExprFunc( T_ELM_LIST_LEV , EvalElmListLevel); InstallEvalExprFunc( T_ELMS_LIST_LEV , EvalElmsListLevel); InstallEvalExprFunc( T_ISB_LIST , EvalIsbList); + InstallEvalExprFunc( T_ELM2_LIST , EvalElm2List); + InstallEvalExprFunc( T_ELMX_LIST , EvalElmXList); + InstallPrintExprFunc( T_ELM2_LIST , PrintElm2List); + InstallPrintExprFunc( T_ELMX_LIST , PrintElmXList); + InstallPrintStatFunc( T_ASS_LIST , PrintAssList); InstallPrintStatFunc( T_ASSS_LIST , PrintAsssList); InstallPrintStatFunc( T_ASS_LIST_LEV , PrintAssList); @@ -2972,10 +3223,11 @@ static Int InitKernel ( InstallPrintStatFunc( T_UNB_LIST , PrintUnbList); InstallPrintExprFunc( T_ELM_LIST , PrintElmList); InstallPrintExprFunc( T_ELMS_LIST , PrintElmsList); - InstallPrintExprFunc( T_ELM_LIST_LEV , PrintElmList); + InstallPrintExprFunc( T_ELM_LIST_LEV , PrintElmListLevel); InstallPrintExprFunc( T_ELMS_LIST_LEV , PrintElmsList); InstallPrintExprFunc( T_ISB_LIST , PrintIsbList); + /* install executors, evaluators, and printers for record elements */ InstallExecStatFunc( T_ASS_REC_NAME , ExecAssRecName); InstallExecStatFunc( T_ASS_REC_EXPR , ExecAssRecExpr);