diff --git a/base/pop/getpoploglib/auto/-&-.p b/base/pop/getpoploglib/auto/-&-.p new file mode 100644 index 00000000..8b191aca --- /dev/null +++ b/base/pop/getpoploglib/auto/-&-.p @@ -0,0 +1,186 @@ +compile_mode :pop11 +strict; + +/* TODO: NOTE FOR FUTURE DEVELOPMENT + +We want to add some syntax for merging in a dict object. e.g. + + f( 1, 2, 3 -&- ^^mydict ) + +*/ + +uses kwargs_lib + +section $-kwargs => + -&- + ; + +define sort_keywords( keyword_list ); + syssort( keyword_list, true, alphabefore ) +enddefine; + +define check_only_one( n ); + lvars d = stacklength() fi_- n; + unless d == 1 do + if d < 1 then + mishap( 0, 'Not enough values for optional argument' ) + else + mishap( d, 'Too many values for optional argument' ) + endif + endunless; +enddefine; + +;;; +;;; Now we have to sort the pile of K1, V1, ... Kn, Vn +;;; into keyword order. We do this by using sysSWAP to +;;; swap them into their correct positions. +;;; +;;; It is in this code that we check for duplicate +;;; keywords. +;;; +define permute( keyword_list ); + lvars keyword_vector = {% keyword_list.dl %}; + lvars n = keyword_vector.length; + + returnif( n <= 1 ); ;;; No need to permute if only 1 (or 0). + + lvars position = newproperty( [], 16, false, "perm" ); + lvars kw, n = 0; + for kw in keyword_list do + if position( kw ) then + mishap( kw, 1, 'Repeated keyword for optional arguments' ) + endif; + n + 1 ->> n -> position( kw ) + endfor; + + lvars kw, rank = 0; + for kw in sort_keywords( keyword_list ) do + rank + 1 -> rank; + lvars posn = position( kw ); + unless rank == posn do + ;;; Swap rank and posn over. + lvars jw = keyword_vector( rank ); + + ;;; K1, V1 K2, V2, ...., Kn-1, Vn-1, Kn, Vn + ;;; 2*n 2*(n-1) 2*2 2*1 + lvars rank_stack_offset = 2 * ( n - rank + 1 ); + lvars posn_stack_offset = 2 * ( n - posn + 1 ); + sysSWAP( rank_stack_offset, posn_stack_offset ); + sysSWAP( rank_stack_offset - 1, posn_stack_offset - 1 ); + + ;;; And now record that it has been done. + ( keyword_vector( rank ), keyword_vector( posn ) ) -> ( keyword_vector( posn ), keyword_vector( rank ) ); + ( position( kw ), position( jw ) ) -> ( position( jw ), position( kw ) ); + endunless; + endfor; +enddefine; + +define check_terminator( keyword, check_plain ); + lvars idprops = keyword.identprops; + returnif( + idprops == "syntax" and + keyword.valof == _ and + keyword.length == 1 and + not( isalphacode( keyword( 1 ) ) ) + )( true ); + if check_plain then + unless idprops == 0 or idprops == undef do + mishap( keyword, 1, 'Keyword is not an ordinary identifier' ) + endunless; + endif; + false +enddefine; + +define is_terminator( keyword ); + check_terminator( keyword, false ) +enddefine; + +;;; +;;; This procedure knows a little bit about Pop-11 syntax so +;;; it can infer that some common expressions will deliver a +;;; single value. It isn't very smart, unfortunately, but +;;; it is much better than nothing. +;;; +;;; It knows about these three cases +;;; , e.g. integer, string +;;; , must not be active +;;; " " , +;;; +define guarantee_single_value(); + dlocal proglist_state; ;;; Leave input undisturbed. + + lvars it1 = readitem(); + returnif( it == termin )( false ); + + lvars it2 = readitem(); + returnif( it2 == termin )( false ); + + if it2.is_terminator then + ;;; This looks promising. + not( it1.isword ) or identprops( it1 ) == 0 and not( isactive( it1 ) ) + elseif it1 == """ then + ;;; Still possible. + lvars it3 = readitem(); + if it3 /== """ then + false + else + readitem().is_terminator + endif + else + false + endif +enddefine; + +;;; +;;; This should really be provided as part of the pop11_compile family. +;;; But it isn't. So we have to code it up. +;;; +define compile_single_valued_expr( stack_count_tmpvar ); + ;;; Try to detect important common cases which are guaranteed to + ;;; deliver single results. + if guarantee_single_value() then + pop11_comp_expr() + else + sysCALL( "stacklength" ); + sysPOP( stack_count_tmpvar ); + pop11_comp_expr(); + sysPUSH( stack_count_tmpvar ); + sysCALLQ( check_only_one ); + endif +enddefine; + +define syntax 12 -&- ; + dlocal pop_new_lvar_list; + + pop_expr_inst( pop_expr_item ); + + ;;; Add the base of the kwargs-pile. + sysPUSHQ( pop_kwargs_bottom_mark ); + + lvars k = sysNEW_LVAR(); + lvars keywords = []; + + lvars count = 0; + repeat + lvars keyword = nextreaditem(); + quitif( check_terminator( keyword, false ) ); + readitem() -> _; + + count + 1 -> count; + keyword :: keywords -> keywords; + + pop11_need_nextreaditem( KEY_VALUE_SEPARATOR ) -> _; + sysPUSHQ( keyword ); + compile_single_valued_expr( k ); + quitunless( pop11_try_nextreaditem( "," ) ); + endrepeat; + keywords.ncrev -> keywords; + + permute( keywords ); + + ;;; Put the cap on the kwargs-pile. + sysPUSHQ -> pop_expr_inst; + pop_kwargs_top_mark -> pop_expr_item; +enddefine; + + +endsection; diff --git a/base/pop/getpoploglib/auto/define_kwargs.p b/base/pop/getpoploglib/auto/define_kwargs.p new file mode 100644 index 00000000..132c6056 --- /dev/null +++ b/base/pop/getpoploglib/auto/define_kwargs.p @@ -0,0 +1,77 @@ +compile_mode :pop11 +strict; + +uses lvars_kwargs; + +section $-kwargs => + define_kwargs + ; + +;;; We may assume that the header is correctly formatted as the more +;;; intensive checking is done in lvars_kwargs. If it is badly formatted we +;;; just bail early with a meaningless count - but that won't get used. +define get_kwargs_nargs( closer ) -> count; + dlocal proglist; + 0 -> count; + until pop11_try_nextreaditem( closer ) do + lconstant closers_procedure_dlocal = [procedure dlocal]; + while pop11_try_nextreaditem( closers_procedure_dlocal ) do + ;;; Skip + endwhile; + lvars variable = readitem(); + quitunless( variable.isword ); + nextif( variable == "," ); + lvars idprops = identprops( variable ); + quitunless( idprops == 0 or idprops == "undef" ); + count + 1 -> count + enduntil; +enddefine; + +;;; +;;; The strategy is macro-like. We rewrite proglist so as to move the +;;; argument processing into a lvars_kwargs & then loop back to -define-. +;;; The reason for doing this is that it is difficult to independently use the +;;; available pop11_* planting procedures, which are too tightly bound to +;;; the standard grammar, and we must use these for quitloop and return to work. +;;; +define :define_form kwargs; + + define lconstant split_at( L, tok ); + lvars before = [% + repeat + if null( L ) then + mishap( tok, 1, 'Missing expected item in header' ) + endif; + lvars t = L.dest -> L; + quitif( tok == t ); + t + endrepeat + %]; + return( before, L ) + enddefine; + + lvars header = [% + repeat + lvars item = readitem(); + quitif( item == ";" ); + item + endrepeat + %]; + + lvars ( prefix, rest ) = split_at( header, "(" ); + lvars ( params, suffix ) = split_at( rest, ")" ); + + lvars nargs = ( + procedure( L ); + dlocal proglist = L; + [proglistL ^L] => + get_kwargs_nargs( [ ^KWARGS_INTRO ) ] ) + endprocedure( params ) + ); + + ;;; Now set up for the next round of -define-. + [ ^^prefix ( ) ^^suffix with_nargs ^nargs; lvars_kwargs ^^params; ^^proglist ] -> proglist; + + nonsyntax define(); +enddefine; + +endsection; diff --git a/base/pop/getpoploglib/auto/lvars_kwargs.p b/base/pop/getpoploglib/auto/lvars_kwargs.p new file mode 100644 index 00000000..0c9651b6 --- /dev/null +++ b/base/pop/getpoploglib/auto/lvars_kwargs.p @@ -0,0 +1,385 @@ +/* +Usage pattern + + f( E1, E2 ..., Em -&- K1 = OptE1, K2 = OptE2, ..., Kn = OptEn ) + + lvars_named_args a, b, c -&- gc = "perm", eq = false, hash = false; + +Implementation scheme. We arrange for -&- to leave the +keywords in SORTED order. Here's a summary + + -&- K1 = V1, K2 = V2, ..., K = Vn + + where n >= 1 + and K1 ... Kn are all distinct + +turns into the following stack-pattern (from bottom to top) + + BOTTOM_MARK, + K'1, V'1, K'2, V'2, ..., K'n, V'n, + TOP_MARK + + where K'1 < K'2 < ... < K'n + and K'1 ... K'n is a permutation of K1, ..., Kn + and V'1 ... V'n is the same permutation of V1, ... Vn + +NOTE 1 +------ +We also have mandatory named arguments, indicated by an omission +of the defaults. These must be provided using the optional arguments +mechanism. e.g. + + ;;; The following can only be satisfied by a stack that looks like: + ;;; VALUE_FOR_ALPHA, BOTTOM_MARK, "beta", VALUE_FOR_BETA, TOP_MARK + lvars_named_args alpha -&- beta; + +NOTE 2 +------ +The internal variables of the parameters can be distinct from their +parameter-name. To make this work use the renaming syntax. e.g. + + ;;; The following uses a keyword 'secondary' but the internal + ;;; variable is my_list2. + lvars_named_args my_list1 -&- my_list2/secondary = []; + +NOTE 3 +------ +Default expressions are different from default values. Default +values can only appear in define :kwargs. + +*/ + +compile_mode :pop11 +strict; + +uses int_parameters +uses kwargs_lib + +section $-kwargs => + lvars_kwargs, ;;; Syntax for argument processing. +; + +;;; Variable/Keyword pairs +defclass vk { + vk_variable, + vk_keyword +}; +constant procedure new_vk = consvk; + +define descending( vk1, vk2 ); + alphabefore( vk2.vk_keyword, vk1.vk_keyword ) +enddefine; + +define sort_vk_list( vk_list ); + syssort( vk_list, true, descending ) +enddefine; + +define plant_fast_decrement( count ); + sysPUSH( count ); + sysPUSHQ( 1 ); + sysCALL( "fi_-" ); ;;; Safe to use fi_- because we don't care if count becomes junk. + sysPOP( count ); +enddefine; + +define plant_eq( variable, value ); + sysPUSH( variable ); + sysPUSHQ( value ); + sysCALL( "==" ); +enddefine; + +define get_args( closers, opt_allowed ) -> ( positional_args, closer ); + [% + until pop11_try_nextitem( closers ) ->> closer do + lvars is_proc = false; + lvars is_dlocal = false; + repeat + lvars tok = pop11_try_nextreaditem( [ procedure dlocal ] ); + quitunless( tok ); + if tok == "procedure" then + true -> is_proc; + elseif tok == "dlocal" then + true -> is_dlocal; + endif + endrepeat; + + lvars variable = readitem(); + nextif( variable == "," ); + + unless variable.isword do + mishap( 'Unexpected item in procedure header', [ ^variable ] ) + endunless; + lvars idprops = identprops( variable ); + unless idprops == 0 or idprops == "undef" do + mishap( 'Parameter not an ordinary word', [ ^variable ] ) + endunless; + + lvars keyword = ( + if pop11_try_nextreaditem( RENAME_SEPARATOR ) then + readitem() + else + variable + endif + ); + if is_dlocal then + sysLOCAL( variable ) + else + sysLVARS( variable, is_proc or 0 ) + endif; + if opt_allowed.isproperty then + if pop11_try_nextitem( KEY_VALUE_SEPARATOR ) then + pop11_comp_expr(); + sysPOP( variable ); + else + sysNEW_LVAR() -> keyword.opt_allowed; + endif + endif; + new_vk( variable, keyword ); + enduntil; + %] -> positional_args; +enddefine; + +define plant_optional_args( optional_args, nondefault ); + + define lconstant check_progress( progress, kw ) -> n; + stacklength() -> n; + if progress == n then + mishap( kw, 1, 'Unrecognised keyword argument' ) + endif + enddefine; + + define lconstant are_kwargs_present(); + stacklength() /== 0 and + lblock + lvars t = (); + t == pop_kwargs_top_mark or ( t, false ) + endlblock + enddefine; + + define lconstant mishap_defaultless_not_initialised( uninitialised ); + mishap( uninitialised, 1, 'Defaultless named argument not assigned' ) + enddefine; + + define lconstant get_next( kw, arg, label ); + sysPUSHS( arg ); + sysPOP( arg ); + sysPUSHQ( pop_kwargs_bottom_mark ); + sysCALL( "==" ); + sysIFSO( label ); + sysPOP( kw ); + enddefine; + + /* + lvars tmp_uninitialised_x = "x"; + lvars tmp_uninitialised_y = "y"; + */ + fast_appproperty( + nondefault, + procedure( k, v ); + sysPUSHQ( k ); + sysPOP( v ); + endprocedure + ); + + /* + if are_kwargs_present() then ;;; Removes the mark. + lvars tmp_progress = false; ;;; Not == to any stacklength() + lvars ( tmp_kw, tmp_arg, quitflag ) = getnext(); ;;; Get current couple. + */ + lvars tmp_progress = sysNEW_LVAR(); + lvars end_of_kwargs_processing = sysNEW_LABEL(); + sysCALLQ( are_kwargs_present ); + sysIFNOT( end_of_kwargs_processing ); + sysPUSHQ( false ); + sysPOP( tmp_progress ); + lvars tmp_kw = sysNEW_LVAR(); + lvars tmp_arg = sysNEW_LVAR(); + + lvars until_loop_start = sysNEW_LABEL(); + lvars until_loop_end = sysNEW_LABEL(); + get_next( tmp_kw, tmp_arg, until_loop_end ); + + /* + until quitflag do + */ + sysLABEL( until_loop_start ); + + /* + if tmp_kw == "x" then + tmp_arg -> x; + false -> tmp_uninitialised_x; + getnext() -> ( tmp_kw, tmp_arg, quitflag ); + quitif( quitflag ); + endif; + */ + lvars vk; + for vk in sort_vk_list( optional_args ) do + ;;; sysCALLQ( npr(% '>>> ' <> vk.vk_keyword.word_string % )); + plant_eq( tmp_kw, vk.vk_keyword ); + lvars done = sysNEW_LABEL(); + sysIFNOT( done ); + + sysPUSH( tmp_arg ); + sysPOP( vk.vk_variable ); + + lvars tmp_uninitialised_kw = nondefault( vk.vk_keyword ); + if tmp_uninitialised_kw then + sysPUSHQ( false ); + sysPOP( tmp_uninitialised_kw ); + endif; + + get_next( tmp_kw, tmp_arg, until_loop_end ); + + sysLABEL( done ); + endfor; + + /* + check_progress( tmp_progress, tmp_kw ) -> tmp_progress + */ + sysPUSH( tmp_progress ); + sysPUSH( tmp_kw ); + sysCALLQ( check_progress ); + sysPOP( tmp_progress ); + + /* + sysCALLQ( + procedure(); + lvars L = conslist( stacklength() ); + [after ^L] => + L.dl + endprocedure + ); + */ + + sysGOTO( until_loop_start ); + + /* enduntil + */ + sysLABEL( until_loop_end ); + + /* + lvars uninitialised = tmp_uninitialised_x or tmp_uninitialised_y; + if uninitialised then + mishap( uninitialised, 1, 'Defaultless named argument not assigned' ) + endif + */ + if datalength( nondefault ) > 0 then + dlvars lab = sysNEW_LABEL(); + dlvars sys_or = erase; + lvars uninitialised = sysNEW_LVAR(); + fast_appproperty( + nondefault, + procedure( kw, tmp_uninitialised_kw ); + sys_or( lab ); + sysOR -> sys_or; + sysPUSH( tmp_uninitialised_kw ); + endprocedure + ); + sysLABEL( lab ); + sysPOP( uninitialised ); + sysPUSH( uninitialised ); + sysIFNOT( end_of_kwargs_processing ); + sysPUSH( uninitialised ); + sysCALLQ( mishap_defaultless_not_initialised ); + endif; + + /* endif + */ + sysLABEL( end_of_kwargs_processing ); +enddefine; + +/* Example: the code generated for `lvars_opt v, w -&- x, y, z = 99;` should look + like this. + + define lconstant check_progress( progress, kw ) -> n; + stacklength() -> n; + if progress == n then + mishap( kw, 1, 'Unrecognised named argument' ) + endif + enddefine; + + define lconstant are_kwargs_present(); + stacklength() == 0 and () == pop_kwargs_top_mark + enddefine; + + define lconstant getnext() -> ( kw, arg, quitflag ); + ;;; We will inline this function. + () -> arg; + arg == pop_kwargs_bottom_mark -> quitflag; + if quitflag then + undef + else + () + endif -> kw + enddefine; + + lvars z; + 99 -> z; + lvars y; + lvars x; + lvars w; + lvars v; + + lvars tmp_uninitialised_x = "x"; + lvars tmp_uninitialised_y = "y"; + + if are_kwargs_present() then ;;; Removes the mark. + lvars tmp_progress = false; ;;; Not == to any stacklength() + lvars ( tmp_kw, tmp_arg, quitflag ) = getnext(); ;;; Get current couple. + until quitflag do + if tmp_kw == "z" then + tmp_arg -> z; + getnext() -> ( tmp_kw, tmp_arg, quitflag ); + quitif( quitflag ); + endif; + if tmp_kw == "y" then + tmp_arg -> y; + false -> tmp_uninitialised_y; + getnext() -> ( tmp_kw, tmp_arg, quitflag ); + quitif( quitflag ); + endif; + if tmp_kw == "x" then + tmp_arg -> x; + false -> tmp_uninitialised_x; + getnext() -> ( tmp_kw, tmp_arg, quitflag ); + quitif( quitflag ); + endif; + check_progress( tmp_progress, tmp_kw ) -> tmp_progress + enduntil + endif; + + lvars uninitialised = tmp_uninitialised_x or tmp_uninitialised_y; + if uninitialised then + mishap( uninitialised, 1, 'Defaultless named argument not assigned' ) + endif + + () -> x; + +*/ + +define pop11_declare_kwargs(); + dlocal pop_new_lvar_list; + + lvars ( positional_args, closer ) = get_args( [ ^KWARGS_INTRO ) ; ], false ); + + lvars nondefault = newproperty( [], 16, false, "perm" ); + lvars optional_args = + if closer == KWARGS_INTRO then + get_args( [ ^KWARGS_INTRO ) ; ], nondefault ) -> _ + else + [] + endif; + lvars nargs_optional = optional_args.length; + + unless nargs_optional == 0 do + plant_optional_args( optional_args, nondefault ); + endunless; + + ;;; Now pop the mandatory args. + applist( positional_args.rev, vk_variable <> sysPOP ); +enddefine; + +define global syntax lvars_kwargs; + pop11_declare_kwargs(); + ";" :: proglist -> proglist; +enddefine; + +endsection; diff --git a/base/pop/getpoploglib/auto/pop_kwargs_bottom_mark.p b/base/pop/getpoploglib/auto/pop_kwargs_bottom_mark.p new file mode 100644 index 00000000..3a00e533 --- /dev/null +++ b/base/pop/getpoploglib/auto/pop_kwargs_bottom_mark.p @@ -0,0 +1,2 @@ +compile_mode :pop11 +strict; +uses kwargs_lib diff --git a/base/pop/getpoploglib/auto/pop_kwargs_top_mark.p b/base/pop/getpoploglib/auto/pop_kwargs_top_mark.p new file mode 100644 index 00000000..3a00e533 --- /dev/null +++ b/base/pop/getpoploglib/auto/pop_kwargs_top_mark.p @@ -0,0 +1,2 @@ +compile_mode :pop11 +strict; +uses kwargs_lib diff --git a/base/pop/getpoploglib/help/kwargs b/base/pop/getpoploglib/help/kwargs new file mode 100644 index 00000000..83225019 --- /dev/null +++ b/base/pop/getpoploglib/help/kwargs @@ -0,0 +1,155 @@ +HELP KWARGS Steve Leach, 13th Dec 04 + + uses kwargs + +This library adds a optional-arguments facility to Pop11. This allows the +programmer to define procedures that take both ordinary arguments and +arguments that are named by keywords. Named arguments may be given +defaults - in which case they are optional. + +It provides two syntax words lvars_kwargs and -&- plus a new define +form :kwargs. + + +----------------------------------------------------------------------- +1 Typical Use +----------------------------------------------------------------------- + +Keyword arguments are passed in a special way to procedures. Because +of this, you cannot get them the same way are ordinary arguments. Instead +you should use the syntax word lvars_kwargs. + +For example, this is how one might write a procedure that takes an +ordinary input argument _n and a named argument _______reverse. Note the +use of the marker "-&-" to separate the ordinary argument from the +named argument. + + uses kwargs; + + define upto() -> result with_nargs 1; + lvars_kwargs n -&- reverse = false; + [% lvars i; for i from 1 to n do i endfor %] -> result; + if reverse then result.rev -> result endif + enddefine; + +lvars_kwargs has two jobs. It declares the arguments and processes +them by popping values off the stack or assigning defaults. A default +is defined by following the named argument with an equals sign and then +the default expression. + +If a named argument has a default then it is said to be optional. An +optional named argument may be omitted when the procedure is called. +This is one of the main points of having named arguments and the +more common situation. + +To invoke a procedure that takes optional arguments is done using +the -&- syntax. Each named parameter is followed by an equals sign +and then its value. + + upto( 3 -&- reverse = true ) => + ** [3 2 1] + + +----------------------------------------------------------------------- +2 Mandatory vs Optional Named Arguments +----------------------------------------------------------------------- + +As mentioned above, named arguments usually have defaults and having a +default makes the named argument optional. However, they do not have to +have a default. In that case they become a mandatory named argument. +That simply means that they must be supplied as named arguments with +their values when they are used. + +For example, + +<<>> + + +----------------------------------------------------------------------- +3 Details of lvars_kwargs +----------------------------------------------------------------------- + +The full syntax of lvars_kwargs looks like this + + lvars_kwargs _____________ORDINARY_ARGS -&- __________NAMED_ARGS; + + _____________ORDINARY_ARGS ___::= _[dlocal_|procedure_] _____________VARIABLE_NAME + + _________NAMED_ARG ___::= _____________VARIABLE_NAME _[= _____________DEFAULT_EXPR] + ___::= _____________________VARIABLE_NAME/KEYWORD _[= _____________DEFAULT_EXPR] + +A named argument actually has two parts, an internal variable name and +an external keyword. Usually these are the same name but you can make +them different. This is mainly useful when the external keyword you +want clashes with a reserved name of some kind. + +The values of the named arguments are popped off the stack first. +If the argument is named and optional and was omitted in the call, the +default value or expression is used to obtain a single result which is +used instead. (We cannot guarantee the order in which the defaults are +assigned, so please avoid relying on this.) + +Note that default expressions are only run if the optional argument is +not supplied. + +When all the named arguments have been processed, the ordinary +arguments are assigned in the usual way. + + +----------------------------------------------------------------------- +4 define :kwargs +----------------------------------------------------------------------- + +The define :kwargs syntax allows us to write procedures that used keyword +parameters in a more natural way. Instead of writing + + define upto() -> result with_nargs 1; + lvars_kwargs n -&- reverse = false; + [% lvars i; for i from 1 to n do i endfor %] -> result; + if reverse then result.rev -> result endif + enddefine; + +we can write this: + + define :kwargs upto( n -&- reverse = false ) -> result; + [% lvars i; for i from 1 to n do i endfor %] -> result; + if reverse then result.rev -> result endif; + enddefine; + + +----------------------------------------------------------------------- +5 Implementation +----------------------------------------------------------------------- + +This implementation of optional arguments is designed to tradeoff several +considerations. + + # Calling a kwarg-procedure without any optional + arguments has a miniscule overhead. + + # The cost of processing the optional arguments is low. + + # The cost of constructing a set of optional arguments is + low (statically rather than dynamically). No heap store + is allocated when passing the arguments. + +To achieve this we arrange for -&- to leave the keywords in sorted order and +to not push duplicates. This makes processing the arguments much more +efficient. Note that it would still work even if the keyword/values were not +sorted and it also works when there are duplicates. In summary: + + -&- K1 = V1, K2 = V2, ..., K = Vn + + where n >= 1 + and K1 ... Kn are all distinct + +turns into + + ___________BOTTOM_MARK, K'1, V'1, K'2, V'2, ...., K'n, V'n, ________TOP_MARK + + where K'1 < K'2 < ... < K'n + and K'1 ... K'n is a permutation of K1, ..., Kn + and V'1 ... V'n is the same permutation of V1, ... Vn + +----------------------------------------------------------------------- +----------------------------------------------------------------------- diff --git a/base/pop/getpoploglib/help/kwargs_pile b/base/pop/getpoploglib/help/kwargs_pile new file mode 100644 index 00000000..40eaee38 --- /dev/null +++ b/base/pop/getpoploglib/help/kwargs_pile @@ -0,0 +1,52 @@ +HELP kwargs_pile Steve Leach, Jane 2023 + + uses kwargs_pile + +This is a library for managing a collection of paired key-value items +that are sandwiched between -pop_kwargs_bottom_mark- and +-pop_kwargs_top_mark-. This 'pile' of values is used to pass keyword +arguments to functions. + +new_kwargs_pile() -> PILE + Creates a new empty kwargs-pile i.e. BOTTOM; TOP + + +kwargs_pile_erase( PILE ) + Removes a kwargs pile from the stack. + + +kwargs_pile_length( PILE ) -> N + Returns the number of key-value pairs in the pile, including + any duplicate keys. + + +kwargs_pile_normalise( PILE ) -> NORMALISED_PILE + Makes all the keys of the PILE unique by sorting the pairs into + alphabetic order of keys and eliminating the pairs with duplicated + keys (higher pairs win). + + +kwargs_pile_add( PILE, key, value ) -> PILE + Adds a key value pair into a kwargs-pile. It does not attempt to + eliminate duplicates or keep the pile sorted. + + +kwargs_pile_extend( PILE, map_like ) -> PILE + Adds the entries of a property or dict into a kwargs-pile. It + does not attempt to eliminate duplicates or keep the pile sorted. + + +kwargs_pile_to_dict( PILE ) -> dict + Creates a dict object from a kwargs-pile, consuming the pile. + + +dict_to_kwargs_pile( dict ) -> PILE + Dumps a dict object's contents into a kwargs-pile. + + +kwargs_pile_to_twinlists( PILE ) -> ( keys_list, values_list) + This function consumes a kwargs-pile and separates the keys and + values into two separate lists. The order of items in each list + is preserved. + +----------------------------------------------------------------------- diff --git a/base/pop/getpoploglib/lib/kwargs.p b/base/pop/getpoploglib/lib/kwargs.p new file mode 100644 index 00000000..271d2d2a --- /dev/null +++ b/base/pop/getpoploglib/lib/kwargs.p @@ -0,0 +1,6 @@ +#_TERMIN_IF DEF -&- + +uses kwargs_lib +uses lvars_kwargs +uses define_kwargs +uses -&- diff --git a/base/pop/getpoploglib/lib/kwargs_lib.p b/base/pop/getpoploglib/lib/kwargs_lib.p new file mode 100644 index 00000000..32ae203b --- /dev/null +++ b/base/pop/getpoploglib/lib/kwargs_lib.p @@ -0,0 +1,24 @@ +compile_mode :pop11 +strict; + +section $-kwargs => + pop_kwargs_top_mark, + pop_kwargs_bottom_mark + ; + +#_IF not(DEF pop_kwargs_mark_key) +;;; We do not want this re-executed, so we protect it behind this #_IF check. + +constant pop_kwargs_mark_key = conskey( "pop_kwargs_mark", [full] ); +constant pop_kwargs_top_mark = class_cons( pop_kwargs_mark_key )( "TOP" ); +constant pop_kwargs_bottom_mark = class_cons( pop_kwargs_mark_key )( "BOTTOM" ); + +;;; Syntactic separators. +constant + KWARGS_INTRO = "-&-", + KEY_VALUE_SEPARATOR = "=", + RENAME_SEPARATOR = "/" +; + +#_ENDIF + +endsection; \ No newline at end of file diff --git a/base/pop/getpoploglib/lib/kwargs_pile.p b/base/pop/getpoploglib/lib/kwargs_pile.p new file mode 100644 index 00000000..00107f5e --- /dev/null +++ b/base/pop/getpoploglib/lib/kwargs_pile.p @@ -0,0 +1,131 @@ +compile_mode :pop11 +strict; + +uses kwargs_lib; + +section $-kwargs => + kwargs_pile, + kwargs_pile_to_twinlists + new_kwargs_pile + kwargs_pile_to_dict + dict_to_kwargs_pile + kwargs_pile_erase + kwargs_pile_length + kwargs_pile_normalise + kwargs_pile_add + kwargs_pile_extend + ; + +;;; Hack for -uses-. +vars kwarg_pile = _; + +define constant verify_kwargs_pile(); + lvars m = (); + unless m == pop_kwargs_top_mark do + mishap( m, 1, 'Invalid kwargs-pile, missing top mark' ) + endunless; +enddefine; + +define kwargs_pile_normalise() with_nargs 1; + verify_kwargs_pile(); + lvars pairs = []; + repeat + lvars arg = (); + quitif( arg == pop_kwargs_bottom_mark ); + lvars kw = (); + conspair( conspair( kw, arg ), pairs ) -> pairs + endrepeat; + nc_listsort( + pairs, + procedure( a, b ); + alphabefore( a.front, b.front ) + endprocedure + ) -> pairs; + pop_kwargs_bottom_mark; + lvars prev_k = false; + while pairs.ispair do + lvars p = pairs.sys_grbg_destpair -> pairs; + lvars k = p.front; + if k == prev_k then + () -> _; + sys_grbg_destpair( p ) -> p -> _; + p + else + sys_grbg_destpair( p ) + endif; + k -> prev_k + endwhile; + pop_kwargs_top_mark +enddefine; + +define kwargs_pile_add( key, value ) with_nargs 3; + verify_kwargs_pile(); + key, value, pop_kwargs_top_mark +enddefine; + +define kwargs_pile_extend( maplike ) with_nargs 2; + verify_kwargs_pile(); + if maplike.isdict then + appdict( maplike, identfn ) + elseif maplike.isproperty then + fast_appproperty( + maplike, + procedure( k, v ); + if k.isword then + k, v + else + mishap( k, 1, 'Trying to use a non-word as a keyword' ) + endif + endprocedure + ) + else + mishap( maplike, 1, 'Not a map-like object (or unrecognised)' ) + endif; + pop_kwargs_top_mark +enddefine; + +define kwargs_pile_to_twinlists() -> ( keyword_list, value_list ) with_nargs 1; + verify_kwargs_pile(); + [] -> keyword_list; + [] -> value_list; + repeat + lvars arg = (); + quitif( arg == pop_kwargs_bottom_mark ); + conspair( (), keyword_list ) -> keyword_list; + conspair( arg, value_list ) -> value_list; + endrepeat; +enddefine; + +define new_kwargs_pile(); + ( pop_kwargs_bottom_mark, pop_kwargs_top_mark ) +enddefine; + +define kwargs_pile_erase() with_nargs 1; + verify_kwargs_pile(); + until () == pop_kwargs_bottom_mark do + enduntil; +enddefine; + +define kwargs_pile_to_dict() -> d with_nargs 1; + lvars ( K, V ) = kwargs_pile_to_twinlists(); + newdict_from_twinlists( K, V ) -> d; + sys_grbg_list( K ); + sys_grbg_list( V ); +enddefine; + +define dict_to_kwargs_pile( dict ); + pop_kwargs_bottom_mark; + appdict( dict, identfn ); + pop_kwargs_top_mark +enddefine; + +define kwargs_pile_length() -> count with_nargs 1; + verify_kwargs_pile(); + lvars n = 1; + until subscr_stack( n ) == pop_kwargs_bottom_mark do + n fi_+ 1 -> n + enduntil; + n fi_>> 1 -> count; + pop_kwargs_top_mark +enddefine; + +endsection;