[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 11/12] libpoke: Add `format`
|
From: |
Mohammad-Reza Nabipoor |
|
Subject: |
[PATCH 11/12] libpoke: Add `format` |
|
Date: |
Wed, 26 May 2021 02:51:14 +0430 |
2021-05-23 Mohammad-Reza Nabipoor <mnabipoor@gnu.org>
* common/pk-utils.h (pk_format_binary): New function declaration.
* common/pk-utils.c (pk_format_binary): New function definition.
* libpoke/pkl-lex.l (format): Recognize `format`.
* libpoke/pkl-ast.h (PKL_AST_FORMAT): Define.
(PKL_AST_FORMAT_ARG): Likewise.
(PKL_AST_TYPE_A_FORMATER): Likewise.
(PKL_AST_TYPE_S_FORMATER): Likewise.
(PKL_AST_FORMAT_FMT): Likewise.
(PKL_AST_FORMAT_TYPES): Likewise.
(PKL_AST_FORMAT_ARGS): Likewise.
(PKL_AST_FORMAT_NARGS): Likewise.
(PKL_AST_FORMAT_PREFIX): Likewise.
(PKL_AST_FORMAT_FMT_PROCESSED_P): Likewise.
(struct pkl_ast_format): New struct.
(pkl_ast_make_format): New function declaration.
(PKL_AST_FORMAT_ARG_EXP): Define.
(PKL_AST_FORMAT_ARG_BASE): Likewise.
(PKL_AST_FORMAT_ARG_SUFFIX): Likewise.
(PKL_AST_FORMAT_ARG_BEGIN_SC): Likewise.
(PKL_AST_FORMAT_ARG_END_SC): Likewise.
(PKL_AST_FORMAT_ARG_VALUE_P): Likewise.
(PKL_AST_FORMAT_ARG_FORMAT_MODE): Likewise.
(PKL_AST_FORMAT_ARG_FORMAT_DEPTH): Likewise.
(PKL_AST_FORMAT_MODE_FLAT): Likewise.
(PKL_AST_FORMAT_MODE_TREE): Likewise.
(struct pkl_ast_format_arg): New struct.
(pkl_ast_make_format_arg): New function declaration.
* libpoke/pkl-ast.c (pkl_ast_make_array_type): Add formater closure.
(pkl_ast_make_struct_type): Add formater closure.
(pkl_ast_make_format): New function definition.
(pkl_ast_make_format_arg): Likewise.
(pkl_ast_node_free): Handle `PKL_AST_FORMAT` and `PKL_AST_FORMAT_ARG`.
* libpoke/pkl-tab.y: Define token `FORMAT`.
(primary): Add `format` support.
(format_arg): New rule.
(format_arg_list): Likewise.
* libpoke/pvm.jitter (wrapped-functions): Add `snprintf`.
(PVM_FORMATI): Define.
(PVM_FORMATL): Likewise.
(formati): New instruction.
(formatiu): Likewise.
(formatl): Likewise.
(formatlu): Likewise.
(push-drop-to-nop): New rule.
* libpoke/pkl-insn.def: Add `format{i,iu,l,lu}` instructions. Add
`format` macro instruction.
And also add previously defined instructions: `drop2`, `drop3`, `nip3`.
* libpoke/pkl-asm.c (pkl_asm_insn_format): New function definition.
(pkl_asm_insn): Add support for format macro instruction.
* libpoke/pkl-pass.c (pkl_do_pass_1): Handle `PKL_AST_FORMAT_ARG` and
`PKL_AST_FORMAT`.
* libpoke/pkl-trans.c (pkl_trans1_ps_format): New phase
(pkl_phase_trans1): Register new phase.
* libpoke/pkl-typify.c (pkl_typify1_ps_format): New phase.
(pkl_phase_typify1): Register new phase.
* libpoke/pkl-promo.c (pkl_promo_ps_format): New phase.
(pkl_phase_promo): Register new phase.
* libpoke/pkl-gen.h (PKL_GEN_CTX_IN_FORMATER): Define.
* libpoke/pkl-gen.c (pkl_gen_pr_format): Generate code for `format`.
(pkl_phase_gen): Register new phase.
(pkl_gen_pr_type_offset): Add formater context.
(pkl_gen_ps_type_integral): Likewise.
(pkl_gen_pr_type_function): Likewise.
(pkl_gen_pr_type_array): Likewise.
(pkl_gen_ps_type_string): Likewise.
(pkl_gen_pr_type_struct): Likewise.
* libpoke/pkl-rt.pk (_pkl_strcat3): New function.
(_pkl_indentation): Likewise.
(_pkl_format_int_suffix): Likewise.
(_pkl_reduce_string_array): Likewise.
* libpoke/pkl-gen.pks (format_int_suffix): New RAS macro.
(integral_formater): Likewise.
(offset_formater): Likewise.
(string_formater): Likewise.
(format_boffset): Likewise.
(array_formater): New RAS function.
(struct_formater): Likewise.
* testsuite/poke.pkl/format-1.pk: New test.
* testsuite/poke.pkl/format-2.pk: Likewise.
* testsuite/poke.pkl/format-3.pk: Likewise.
* testsuite/poke.pkl/format-4.pk: Likewise.
* testsuite/poke.pkl/format-5.pk: Likewise.
* testsuite/poke.pkl/format-6.pk: Likewise.
* testsuite/poke.pkl/format-7.pk: Likewise.
* testsuite/poke.pkl/format-8.pk: Likewise.
* testsuite/poke.pkl/format-9.pk: Likewise.
* testsuite/poke.pkl/format-10.pk: Likewise.
* testsuite/poke.pkl/format-11.pk: Likewise.
* testsuite/poke.pkl/format-12.pk: Likewise.
* testsuite/poke.pkl/format-13.pk: Likewise.
* testsuite/poke.pkl/format-14.pk: Likewise.
* testsuite/poke.pkl/format-15.pk: Likewise.
* testsuite/poke.pkl/format-16.pk: Likewise.
* testsuite/poke.pkl/format-17.pk: Likewise.
* testsuite/poke.pkl/format-18.pk: Likewise.
* testsuite/poke.pkl/format-19.pk: Likewise.
* testsuite/poke.pkl/format-20.pk: Likewise.
* testsuite/poke.pkl/format-21.pk: Likewise.
* testsuite/poke.pkl/format-22.pk: Likewise.
* testsuite/poke.pkl/format-23.pk: Likewise.
* testsuite/poke.pkl/format-24.pk: Likewise.
* testsuite/poke.pkl/format-25.pk: Likewise.
* testsuite/poke.pkl/format-26.pk: Likewise.
* testsuite/poke.pkl/format-27.pk: Likewise.
* testsuite/poke.pkl/format-28.pk: Likewise.
* testsuite/poke.pkl/format-29.pk: Likewise.
* testsuite/poke.pkl/format-diag-1.pk: Likewise.
* testsuite/poke.pkl/reduce-array-1.pk: Likewise.
* testsuite/poke.pkl/reduce-array-2.pk: Likewise.
* testsuite/Makefile.am (EXTRA_DIST): Add new tests.
---
ChangeLog | 113 ++++++
common/pk-utils.c | 28 ++
common/pk-utils.h | 4 +
libpoke/pkl-asm.c | 39 ++
libpoke/pkl-ast.c | 82 +++-
libpoke/pkl-ast.h | 116 +++++-
libpoke/pkl-gen.c | 254 ++++++++++++
libpoke/pkl-gen.h | 1 +
libpoke/pkl-gen.pks | 551 +++++++++++++++++++++++++++
libpoke/pkl-insn.def | 14 +
libpoke/pkl-lex.l | 1 +
libpoke/pkl-pass.c | 12 +
libpoke/pkl-promo.c | 39 ++
libpoke/pkl-rt.pk | 68 ++++
libpoke/pkl-tab.y | 36 +-
libpoke/pkl-trans.c | 349 +++++++++++++++++
libpoke/pkl-typify.c | 55 +++
libpoke/pvm.jitter | 205 ++++++++++
testsuite/Makefile.am | 32 ++
testsuite/poke.pkl/format-1.pk | 20 +
testsuite/poke.pkl/format-10.pk | 7 +
testsuite/poke.pkl/format-11.pk | 7 +
testsuite/poke.pkl/format-12.pk | 7 +
testsuite/poke.pkl/format-13.pk | 4 +
testsuite/poke.pkl/format-14.pk | 4 +
testsuite/poke.pkl/format-15.pk | 4 +
testsuite/poke.pkl/format-16.pk | 7 +
testsuite/poke.pkl/format-17.pk | 7 +
testsuite/poke.pkl/format-18.pk | 4 +
testsuite/poke.pkl/format-19.pk | 5 +
testsuite/poke.pkl/format-2.pk | 20 +
testsuite/poke.pkl/format-20.pk | 7 +
testsuite/poke.pkl/format-21.pk | 5 +
testsuite/poke.pkl/format-22.pk | 5 +
testsuite/poke.pkl/format-23.pk | 5 +
testsuite/poke.pkl/format-24.pk | 6 +
testsuite/poke.pkl/format-25.pk | 7 +
testsuite/poke.pkl/format-26.pk | 11 +
testsuite/poke.pkl/format-27.pk | 10 +
testsuite/poke.pkl/format-28.pk | 11 +
testsuite/poke.pkl/format-29.pk | 11 +
testsuite/poke.pkl/format-3.pk | 20 +
testsuite/poke.pkl/format-4.pk | 20 +
testsuite/poke.pkl/format-5.pk | 4 +
testsuite/poke.pkl/format-6.pk | 4 +
testsuite/poke.pkl/format-7.pk | 4 +
testsuite/poke.pkl/format-8.pk | 7 +
testsuite/poke.pkl/format-9.pk | 7 +
testsuite/poke.pkl/format-diag-1.pk | 3 +
testsuite/poke.pkl/reduce-array-1.pk | 7 +
testsuite/poke.pkl/reduce-array-2.pk | 7 +
51 files changed, 2244 insertions(+), 12 deletions(-)
create mode 100644 testsuite/poke.pkl/format-1.pk
create mode 100644 testsuite/poke.pkl/format-10.pk
create mode 100644 testsuite/poke.pkl/format-11.pk
create mode 100644 testsuite/poke.pkl/format-12.pk
create mode 100644 testsuite/poke.pkl/format-13.pk
create mode 100644 testsuite/poke.pkl/format-14.pk
create mode 100644 testsuite/poke.pkl/format-15.pk
create mode 100644 testsuite/poke.pkl/format-16.pk
create mode 100644 testsuite/poke.pkl/format-17.pk
create mode 100644 testsuite/poke.pkl/format-18.pk
create mode 100644 testsuite/poke.pkl/format-19.pk
create mode 100644 testsuite/poke.pkl/format-2.pk
create mode 100644 testsuite/poke.pkl/format-20.pk
create mode 100644 testsuite/poke.pkl/format-21.pk
create mode 100644 testsuite/poke.pkl/format-22.pk
create mode 100644 testsuite/poke.pkl/format-23.pk
create mode 100644 testsuite/poke.pkl/format-24.pk
create mode 100644 testsuite/poke.pkl/format-25.pk
create mode 100644 testsuite/poke.pkl/format-26.pk
create mode 100644 testsuite/poke.pkl/format-27.pk
create mode 100644 testsuite/poke.pkl/format-28.pk
create mode 100644 testsuite/poke.pkl/format-29.pk
create mode 100644 testsuite/poke.pkl/format-3.pk
create mode 100644 testsuite/poke.pkl/format-4.pk
create mode 100644 testsuite/poke.pkl/format-5.pk
create mode 100644 testsuite/poke.pkl/format-6.pk
create mode 100644 testsuite/poke.pkl/format-7.pk
create mode 100644 testsuite/poke.pkl/format-8.pk
create mode 100644 testsuite/poke.pkl/format-9.pk
create mode 100644 testsuite/poke.pkl/format-diag-1.pk
create mode 100644 testsuite/poke.pkl/reduce-array-1.pk
create mode 100644 testsuite/poke.pkl/reduce-array-2.pk
diff --git a/ChangeLog b/ChangeLog
index ba235f82..eac9b1d3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,116 @@
+2021-05-23 Mohammad-Reza Nabipoor <mnabipoor@gnu.org>
+
+ * common/pk-utils.h (pk_format_binary): New function declaration.
+ * common/pk-utils.c (pk_format_binary): New function definition.
+ * libpoke/pkl-lex.l (format): Recognize `format`.
+ * libpoke/pkl-ast.h (PKL_AST_FORMAT): Define.
+ (PKL_AST_FORMAT_ARG): Likewise.
+ (PKL_AST_TYPE_A_FORMATER): Likewise.
+ (PKL_AST_TYPE_S_FORMATER): Likewise.
+ (PKL_AST_FORMAT_FMT): Likewise.
+ (PKL_AST_FORMAT_TYPES): Likewise.
+ (PKL_AST_FORMAT_ARGS): Likewise.
+ (PKL_AST_FORMAT_NARGS): Likewise.
+ (PKL_AST_FORMAT_PREFIX): Likewise.
+ (PKL_AST_FORMAT_FMT_PROCESSED_P): Likewise.
+ (struct pkl_ast_format): New struct.
+ (pkl_ast_make_format): New function declaration.
+ (PKL_AST_FORMAT_ARG_EXP): Define.
+ (PKL_AST_FORMAT_ARG_BASE): Likewise.
+ (PKL_AST_FORMAT_ARG_SUFFIX): Likewise.
+ (PKL_AST_FORMAT_ARG_BEGIN_SC): Likewise.
+ (PKL_AST_FORMAT_ARG_END_SC): Likewise.
+ (PKL_AST_FORMAT_ARG_VALUE_P): Likewise.
+ (PKL_AST_FORMAT_ARG_FORMAT_MODE): Likewise.
+ (PKL_AST_FORMAT_ARG_FORMAT_DEPTH): Likewise.
+ (PKL_AST_FORMAT_MODE_FLAT): Likewise.
+ (PKL_AST_FORMAT_MODE_TREE): Likewise.
+ (struct pkl_ast_format_arg): New struct.
+ (pkl_ast_make_format_arg): New function declaration.
+ * libpoke/pkl-ast.c (pkl_ast_make_array_type): Add formater closure.
+ (pkl_ast_make_struct_type): Add formater closure.
+ (pkl_ast_make_format): New function definition.
+ (pkl_ast_make_format_arg): Likewise.
+ (pkl_ast_node_free): Handle `PKL_AST_FORMAT` and `PKL_AST_FORMAT_ARG`.
+ * libpoke/pkl-tab.y: Define token `FORMAT`.
+ (primary): Add `format` support.
+ (format_arg): New rule.
+ (format_arg_list): Likewise.
+ * libpoke/pvm.jitter (wrapped-functions): Add `snprintf`.
+ (PVM_FORMATI): Define.
+ (PVM_FORMATL): Likewise.
+ (formati): New instruction.
+ (formatiu): Likewise.
+ (formatl): Likewise.
+ (formatlu): Likewise.
+ (push-drop-to-nop): New rule.
+ * libpoke/pkl-insn.def: Add `format{i,iu,l,lu}` instructions. Add
+ `format` macro instruction.
+ And also add previously defined instructions: `drop2`, `drop3`, `nip3`.
+ * libpoke/pkl-asm.c (pkl_asm_insn_format): New function definition.
+ (pkl_asm_insn): Add support for format macro instruction.
+ * libpoke/pkl-pass.c (pkl_do_pass_1): Handle `PKL_AST_FORMAT_ARG` and
+ `PKL_AST_FORMAT`.
+ * libpoke/pkl-trans.c (pkl_trans1_ps_format): New phase
+ (pkl_phase_trans1): Register new phase.
+ * libpoke/pkl-typify.c (pkl_typify1_ps_format): New phase.
+ (pkl_phase_typify1): Register new phase.
+ * libpoke/pkl-promo.c (pkl_promo_ps_format): New phase.
+ (pkl_phase_promo): Register new phase.
+ * libpoke/pkl-gen.h (PKL_GEN_CTX_IN_FORMATER): Define.
+ * libpoke/pkl-gen.c (pkl_gen_pr_format): Generate code for `format`.
+ (pkl_phase_gen): Register new phase.
+ (pkl_gen_pr_type_offset): Add formater context.
+ (pkl_gen_ps_type_integral): Likewise.
+ (pkl_gen_pr_type_function): Likewise.
+ (pkl_gen_pr_type_array): Likewise.
+ (pkl_gen_ps_type_string): Likewise.
+ (pkl_gen_pr_type_struct): Likewise.
+ * libpoke/pkl-rt.pk (_pkl_strcat3): New function.
+ (_pkl_indentation): Likewise.
+ (_pkl_format_int_suffix): Likewise.
+ (_pkl_reduce_string_array): Likewise.
+ * libpoke/pkl-gen.pks (format_int_suffix): New RAS macro.
+ (integral_formater): Likewise.
+ (offset_formater): Likewise.
+ (string_formater): Likewise.
+ (format_boffset): Likewise.
+ (array_formater): New RAS function.
+ (struct_formater): Likewise.
+ * testsuite/poke.pkl/format-1.pk: New test.
+ * testsuite/poke.pkl/format-2.pk: Likewise.
+ * testsuite/poke.pkl/format-3.pk: Likewise.
+ * testsuite/poke.pkl/format-4.pk: Likewise.
+ * testsuite/poke.pkl/format-5.pk: Likewise.
+ * testsuite/poke.pkl/format-6.pk: Likewise.
+ * testsuite/poke.pkl/format-7.pk: Likewise.
+ * testsuite/poke.pkl/format-8.pk: Likewise.
+ * testsuite/poke.pkl/format-9.pk: Likewise.
+ * testsuite/poke.pkl/format-10.pk: Likewise.
+ * testsuite/poke.pkl/format-11.pk: Likewise.
+ * testsuite/poke.pkl/format-12.pk: Likewise.
+ * testsuite/poke.pkl/format-13.pk: Likewise.
+ * testsuite/poke.pkl/format-14.pk: Likewise.
+ * testsuite/poke.pkl/format-15.pk: Likewise.
+ * testsuite/poke.pkl/format-16.pk: Likewise.
+ * testsuite/poke.pkl/format-17.pk: Likewise.
+ * testsuite/poke.pkl/format-18.pk: Likewise.
+ * testsuite/poke.pkl/format-19.pk: Likewise.
+ * testsuite/poke.pkl/format-20.pk: Likewise.
+ * testsuite/poke.pkl/format-21.pk: Likewise.
+ * testsuite/poke.pkl/format-22.pk: Likewise.
+ * testsuite/poke.pkl/format-23.pk: Likewise.
+ * testsuite/poke.pkl/format-24.pk: Likewise.
+ * testsuite/poke.pkl/format-25.pk: Likewise.
+ * testsuite/poke.pkl/format-26.pk: Likewise.
+ * testsuite/poke.pkl/format-27.pk: Likewise.
+ * testsuite/poke.pkl/format-28.pk: Likewise.
+ * testsuite/poke.pkl/format-29.pk: Likewise.
+ * testsuite/poke.pkl/format-diag-1.pk: Likewise.
+ * testsuite/poke.pkl/reduce-array-1.pk: Likewise.
+ * testsuite/poke.pkl/reduce-array-2.pk: Likewise.
+ * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
+
2021-05-23 Mohammad-Reza Nabipoor <mnabipoor@gnu.org>
* libpoke/pvm.jitter (sprops): Add instruction for
diff --git a/common/pk-utils.c b/common/pk-utils.c
index 620c99fb..2db67094 100644
--- a/common/pk-utils.c
+++ b/common/pk-utils.c
@@ -107,6 +107,34 @@ pk_print_binary (void (*puts_fn) (const char *str),
puts_fn (sign ? "N" : "UN");
}
+int
+pk_format_binary (char* out, size_t outlen,
+ uint64_t val, int size, int sign)
+{
+ char b[64 /* digits */ + 2 /* suffix */ + 1 /* nul */];
+
+ for (int z = 0; z < size; z++) {
+ b[size-1-z] = ((val >> z) & 0x1) + '0';
+ }
+ b[size] = '\0';
+
+ if (size == 64)
+ strcat (b, sign ? "L" : "UL");
+ else if (size == 16)
+ strcat (b, sign ? "H" : "UH");
+ else if (size == 8)
+ strcat (b, sign ? "B" : "UB");
+ else if (size == 4)
+ strcat (b, sign ? "N" : "UN");
+
+ if (strlen (b) < outlen)
+ {
+ strcpy (out, b);
+ return 0; /* success */
+ }
+ return 1; /* fail */
+}
+
/* Concatenate 2+ strings.
* Last argument must be NULL.
* Returns the malloc'ed concatenated string or NULL when out of memory.
diff --git a/common/pk-utils.h b/common/pk-utils.h
index 0d97e367..7e3810d0 100644
--- a/common/pk-utils.h
+++ b/common/pk-utils.h
@@ -50,6 +50,10 @@ uint64_t pk_upow (uint64_t base, uint32_t exp);
/* Print the given unsigned 64-bit integer in binary. */
void pk_print_binary (void (*puts_fn) (const char *str), uint64_t val, int
size, int sign);
+/* Format the given unsigned 64-bit integer in binary. */
+int pk_format_binary (char* out, size_t outlen, uint64_t val, int size,
+ int sign);
+
/* Concatenate string arguments into an malloc'ed string. */
char *pk_str_concat (const char *s0, ...) __attribute__ ((sentinel));
diff --git a/libpoke/pkl-asm.c b/libpoke/pkl-asm.c
index 9560e753..02ca6b96 100644
--- a/libpoke/pkl-asm.c
+++ b/libpoke/pkl-asm.c
@@ -453,6 +453,34 @@ pkl_asm_insn_rev (pkl_asm pasm, unsigned int depth)
pkl_asm_insn (pasm, PKL_INSN_REVN, depth);
}
+/* Macro-instruction: FORMAT type
+ ( OBASE VAL -- )
+*/
+
+static void
+pkl_asm_insn_format (pkl_asm pasm, pkl_ast_node type)
+{
+ int type_code = PKL_AST_TYPE_CODE (type);
+
+ if (type_code == PKL_TYPE_STRING)
+ pkl_asm_insn (pasm, PKL_INSN_DROP); /* The base. */
+ else if (type_code == PKL_TYPE_INTEGRAL)
+ {
+ static const int format_table[2][2] =
+ {
+ {PKL_INSN_FORMATIU, PKL_INSN_FORMATI},
+ {PKL_INSN_FORMATLU, PKL_INSN_FORMATL}
+ };
+ size_t size = PKL_AST_TYPE_I_SIZE (type);
+ int signed_p = PKL_AST_TYPE_I_SIGNED_P (type);
+
+ pkl_asm_insn (pasm, format_table[size > 32][signed_p],
+ (unsigned int) size);
+ }
+ else
+ assert (0);
+}
+
/* Macro-instruction: PRINT type
( OBASE VAL -- )
*/
@@ -1386,6 +1414,17 @@ pkl_asm_insn (pkl_asm pasm, enum pkl_asm_insn insn, ...)
pkl_asm_insn_poke (pasm, type, nenc, endian);
break;
}
+ case PKL_INSN_FORMAT:
+ {
+ pkl_ast_node type;
+
+ va_start (valist, insn);
+ type = va_arg (valist, pkl_ast_node);
+ va_end (valist);
+
+ pkl_asm_insn_format (pasm, type);
+ break;
+ }
case PKL_INSN_PRINT:
{
pkl_ast_node type;
diff --git a/libpoke/pkl-ast.c b/libpoke/pkl-ast.c
index 5c08b65b..5994d0f2 100644
--- a/libpoke/pkl-ast.c
+++ b/libpoke/pkl-ast.c
@@ -370,7 +370,8 @@ pkl_ast_node
pkl_ast_make_array_type (pkl_ast ast, pkl_ast_node etype, pkl_ast_node bound)
{
pkl_ast_node type = pkl_ast_make_type (ast);
- const int nclosures = 5; /* mapper, writer, bounder, constructor, printer */
+ const int nclosures
+ = 6; /* mapper, writer, bounder, constructor, printer, formater. */
assert (etype);
@@ -386,6 +387,7 @@ pkl_ast_make_array_type (pkl_ast ast, pkl_ast_node etype,
pkl_ast_node bound)
PKL_AST_TYPE_A_WRITER (type) = PVM_NULL;
PKL_AST_TYPE_A_BOUNDER (type) = PVM_NULL;
PKL_AST_TYPE_A_CONSTRUCTOR (type) = PVM_NULL;
+ PKL_AST_TYPE_A_FORMATER (type) = PVM_NULL;
PKL_AST_TYPE_A_PRINTER (type) = PVM_NULL;
return type;
@@ -441,8 +443,8 @@ pkl_ast_make_struct_type (pkl_ast ast,
int pinned_p, int union_p)
{
pkl_ast_node type = pkl_ast_make_type (ast);
- const int nclosures
- = 6; /* writer, mapper, constructor, comparator, integrator, printer. */
+ const int nclosures = 7; /* writer, mapper, constructor, comparator,
+ integrator, printer, formater. */
PKL_AST_TYPE_CODE (type) = PKL_TYPE_STRUCT;
PKL_AST_TYPE_S_NELEM (type) = nelem;
@@ -463,6 +465,7 @@ pkl_ast_make_struct_type (pkl_ast ast,
PKL_AST_TYPE_S_CONSTRUCTOR (type) = PVM_NULL;
PKL_AST_TYPE_S_COMPARATOR (type) = PVM_NULL;
PKL_AST_TYPE_S_INTEGRATOR (type) = PVM_NULL;
+ PKL_AST_TYPE_S_FORMATER (type) = PVM_NULL;
PKL_AST_TYPE_S_PRINTER (type) = PVM_NULL;
return type;
@@ -1569,6 +1572,33 @@ pkl_ast_make_funcall_arg (pkl_ast ast, pkl_ast_node exp,
return funcall_arg;
}
+/* Build and return an AST node for `format'. */
+
+pkl_ast_node
+pkl_ast_make_format (pkl_ast ast,
+ pkl_ast_node fmt, pkl_ast_node args)
+{
+ pkl_ast_node format = pkl_ast_make_node (ast, PKL_AST_FORMAT);
+
+ PKL_AST_FORMAT_FMT (format) = ASTREF (fmt);
+ if (args)
+ PKL_AST_FORMAT_ARGS (format) = ASTREF (args);
+
+ return format;
+}
+
+/* Build and return an AST node for a `format' argument. */
+
+pkl_ast_node
+pkl_ast_make_format_arg (pkl_ast ast, pkl_ast_node exp)
+{
+ pkl_ast_node format_arg = pkl_ast_make_node (ast, PKL_AST_FORMAT_ARG);
+
+ if (exp)
+ PKL_AST_FORMAT_ARG_EXP (format_arg) = ASTREF (exp);
+ return format_arg;
+}
+
/* Build and return an AST node for a variable reference. */
pkl_ast_node
@@ -2250,6 +2280,30 @@ pkl_ast_node_free (pkl_ast_node ast)
pkl_ast_node_free (PKL_AST_TRY_UNTIL_STMT_EXP (ast));
break;
+ case PKL_AST_FORMAT_ARG:
+ free (PKL_AST_FORMAT_ARG_SUFFIX (ast));
+ free (PKL_AST_FORMAT_ARG_BEGIN_SC (ast));
+ free (PKL_AST_FORMAT_ARG_END_SC (ast));
+ pkl_ast_node_free (PKL_AST_FORMAT_ARG_EXP (ast));
+ break;
+
+ case PKL_AST_FORMAT:
+ {
+ free (PKL_AST_FORMAT_PREFIX (ast));
+ for (t = PKL_AST_FORMAT_ARGS (ast); t; t = n)
+ {
+ n = PKL_AST_CHAIN (t);
+ pkl_ast_node_free (t);
+ }
+ for (t = PKL_AST_FORMAT_TYPES (ast); t; t = n)
+ {
+ n = PKL_AST_CHAIN (t);
+ pkl_ast_node_free (t);
+ }
+ pkl_ast_node_free (PKL_AST_FORMAT_FMT (ast));
+ break;
+ }
+
case PKL_AST_PRINT_STMT_ARG:
free (PKL_AST_PRINT_STMT_ARG_SUFFIX (ast));
free (PKL_AST_PRINT_STMT_ARG_BEGIN_SC (ast));
@@ -3024,6 +3078,28 @@ pkl_ast_print_1 (FILE *fp, pkl_ast_node ast, int indent)
PRINT_AST_SUBAST (function, LAMBDA_FUNCTION);
break;
+ case PKL_AST_FORMAT_ARG:
+ IPRINTF ("FORMAT_ARG::\n");
+ PRINT_COMMON_FIELDS;
+ if (PKL_AST_FORMAT_ARG_BEGIN_SC (ast))
+ PRINT_AST_IMM (begin_sc, FORMAT_ARG_BEGIN_SC, "'%s'");
+ if (PKL_AST_FORMAT_ARG_END_SC (ast))
+ PRINT_AST_IMM (end_sc, FORMAT_ARG_END_SC, "'%s'");
+ if (PKL_AST_FORMAT_ARG_SUFFIX (ast))
+ PRINT_AST_IMM (suffix, FORMAT_ARG_SUFFIX, "'%s'");
+ PRINT_AST_SUBAST (exp, FORMAT_ARG_EXP);
+ break;
+
+ case PKL_AST_FORMAT:
+ IPRINTF ("FORMAT::\n");
+ PRINT_COMMON_FIELDS;
+ if (PKL_AST_FORMAT_PREFIX (ast))
+ PRINT_AST_IMM (prefix, FORMAT_PREFIX, "'%s'");
+ PRINT_AST_SUBAST (fmt, FORMAT_FMT);
+ PRINT_AST_SUBAST_CHAIN (FORMAT_TYPES);
+ PRINT_AST_SUBAST_CHAIN (FORMAT_ARGS);
+ break;
+
case PKL_AST_INCRDECR:
IPRINTF ("INCRDECR::\n");
diff --git a/libpoke/pkl-ast.h b/libpoke/pkl-ast.h
index 550b9f48..74208228 100644
--- a/libpoke/pkl-ast.h
+++ b/libpoke/pkl-ast.h
@@ -57,6 +57,8 @@ enum pkl_ast_code
PKL_AST_FUNCALL_ARG,
PKL_AST_VAR,
PKL_AST_LAMBDA,
+ PKL_AST_FORMAT,
+ PKL_AST_FORMAT_ARG,
PKL_AST_INCRDECR,
PKL_AST_GCD,
PKL_AST_LAST_EXP = PKL_AST_GCD,
@@ -850,8 +852,8 @@ pkl_ast_node pkl_ast_make_func_type_arg (pkl_ast ast,
number of elements, then BOUND is an expression that must evaluate
to an integer. If the array type is bounded by size, then BOUND is
an expression that must evaluate to an offset. If the array type
- is unbounded, then BOUND is NULL. MAPPER, WRITER, PRINTER,
- CONSTRUCTOR and BOUNDCLS are used to hold closures, or
+ is unbounded, then BOUND is NULL. MAPPER, WRITER, FORMATER,
+ PRINTER, CONSTRUCTOR and BOUNDCLS are used to hold closures, or
PVM_NULL. The field LEX_CORRECTED is used by the transl phase, to
keep record of array types that have been lexically corrected; this
is to avoid processing the same type more than once.
@@ -861,9 +863,9 @@ pkl_ast_node pkl_ast_make_func_type_arg (pkl_ast ast,
declarations. ELEMS is a chain of elements, which can be
PKL_AST_STRUCT_TYPE_FIELD or PKL_AST_DECL nodes, potentially mixed.
PINNED_P is 1 if the struct is pinned, 0 otherwise. MAPPER, WRITER
- CONSTRUCTOR, PRINTER, COMPARATOR and INTEGRATOR are used to hold
- closures, or PVM_NULL. INT_TYPE, if not NULL, is an AST node with
- an integral type, that defines the nature of this struct type as
+ CONSTRUCTOR, FORMATER, PRINTER, COMPARATOR and INTEGRATOR are used to
+ hold closures, or PVM_NULL. INT_TYPE, if not NULL, is an AST node
+ with an integral type, that defines the nature of this struct type as
integral.
In offset types, BASE_TYPE is a PKL_AST_TYPE with the base type for
@@ -898,6 +900,7 @@ pkl_ast_node pkl_ast_make_func_type_arg (pkl_ast ast,
#define PKL_AST_TYPE_A_BOUNDER(AST) ((AST)->type.val.array.closures[2])
#define PKL_AST_TYPE_A_CONSTRUCTOR(AST) ((AST)->type.val.array.closures[3])
#define PKL_AST_TYPE_A_PRINTER(AST) ((AST)->type.val.array.closures[4])
+#define PKL_AST_TYPE_A_FORMATER(AST) ((AST)->type.val.array.closures[5])
#define PKL_AST_TYPE_S_NFIELD(AST) ((AST)->type.val.sct.nfield)
#define PKL_AST_TYPE_S_NDECL(AST) ((AST)->type.val.sct.ndecl)
#define PKL_AST_TYPE_S_NELEM(AST) ((AST)->type.val.sct.nelem)
@@ -911,6 +914,7 @@ pkl_ast_node pkl_ast_make_func_type_arg (pkl_ast ast,
#define PKL_AST_TYPE_S_PRINTER(AST) ((AST)->type.val.sct.closures[3])
#define PKL_AST_TYPE_S_COMPARATOR(AST) ((AST)->type.val.sct.closures[4])
#define PKL_AST_TYPE_S_INTEGRATOR(AST) ((AST)->type.val.sct.closures[5])
+#define PKL_AST_TYPE_S_FORMATER(AST) ((AST)->type.val.sct.closures[6])
#define PKL_AST_TYPE_S_ITYPE(AST) ((AST)->type.val.sct.itype)
#define PKL_AST_TYPE_O_UNIT(AST) ((AST)->type.val.off.unit)
#define PKL_AST_TYPE_O_BASE_TYPE(AST) ((AST)->type.val.off.base_type)
@@ -945,8 +949,8 @@ struct pkl_ast_type
{
union pkl_ast_node *bound;
union pkl_ast_node *etype;
- /* Uncollectable array for MAPPER, BOUNDER, WRITER, CONSTRUCTOR
- and PRINTER. */
+ /* Uncollectable array for MAPPER, BOUNDER, WRITER, CONSTRUCTOR,
+ PRINTER and FORMATER. */
pvm_val *closures;
} array;
@@ -960,7 +964,7 @@ struct pkl_ast_type
int pinned_p;
int union_p;
/* Uncollectable array for MAPPER, WRITER, CONSTRUCTOR, COMPARATOR,
- INTEGRATOR and PRINTER. */
+ INTEGRATOR, PRINTER and FORMATER. */
pvm_val *closures;
} sct;
@@ -1287,6 +1291,100 @@ struct pkl_ast_funcall_arg
pkl_ast_node pkl_ast_make_funcall_arg (pkl_ast ast, pkl_ast_node exp,
pkl_ast_node name);
+/* PKL_AST_FORMAT nodes represent `format'.
+
+ ARGS is a chained list of PKL_AST_FORMAT_ARG nodes. This may
+ contain zero or more nodes, and the types of their expressions
+ should match the format expressed in FMT.
+
+ FMT is the format string node.
+
+ TYPES is a linked list of type nodes, corresponding to the %-
+ directives in FMT. Note that %<class> and %</class> directives
+ have type PKL_TYPE_VOID.
+
+ NARGS is the number of arguments in ARGS.
+
+ PREFIX, if not NULL, is a C string that comes before the arguments.
+
+ FMT_PROCESSED_P is a boolean indicating whether the format string
+ has been already processed in this node. */
+
+#define PKL_AST_FORMAT_FMT(AST) ((AST)->format.fmt)
+#define PKL_AST_FORMAT_TYPES(AST) ((AST)->format.types)
+#define PKL_AST_FORMAT_ARGS(AST) ((AST)->format.args)
+#define PKL_AST_FORMAT_NARGS(AST) ((AST)->format.nargs)
+#define PKL_AST_FORMAT_PREFIX(AST) ((AST)->format.prefix)
+#define PKL_AST_FORMAT_FMT_PROCESSED_P(AST) ((AST)->format.fmt_processed_p)
+
+struct pkl_ast_format
+{
+ struct pkl_ast_common common;
+
+ int nargs;
+ char *prefix;
+ int fmt_processed_p;
+ union pkl_ast_node *fmt;
+ union pkl_ast_node *types;
+ union pkl_ast_node *args;
+};
+
+pkl_ast_node pkl_ast_make_format (pkl_ast ast,
+ pkl_ast_node fmt, pkl_ast_node args);
+
+/* PKL_AST_FORMAT_ARG nodes represent expression arguments to `format'.
+
+ EXP is an expression node evaluating to the value to format.
+
+ BASE is the numeration base to use when formating this argument.
+
+ BEGIN_SC, if not NULL, marks that this argument is a %<class>
+ directive, and is a NULL-terminated string with the name of the
+ styling class to begin.
+
+ END_SC, if not NULL, marks that this argument is a %</class>
+ directive, and is a NULL-terminated string with the name of the
+ styling class to end.
+
+ SUFFIX, if not NULL, is a C string that should be appended after the
+ value of EXP, respectively.
+
+ VALUE_P indicates whether the argument shall be printed as a PVM
+ value or not (whether this arguement corresponds to a %v or not).
+
+ FORMAT_MODE and FORMAT_DEPTH specify how the argument shall be
+ printed if VALUE_P is true. FORMAT_MODE can be one of the
+ PKL_AST_FORMAT_MODE_* constants defined below, while FORMAT_DEPTH can
+ be zero or a positive integer. */
+
+#define PKL_AST_FORMAT_ARG_EXP(AST) ((AST)->format_arg.exp)
+#define PKL_AST_FORMAT_ARG_BASE(AST) ((AST)->format_arg.base)
+#define PKL_AST_FORMAT_ARG_SUFFIX(AST) ((AST)->format_arg.suffix)
+#define PKL_AST_FORMAT_ARG_BEGIN_SC(AST) ((AST)->format_arg.begin_sc)
+#define PKL_AST_FORMAT_ARG_END_SC(AST) ((AST)->format_arg.end_sc)
+#define PKL_AST_FORMAT_ARG_VALUE_P(AST) ((AST)->format_arg.value_p)
+#define PKL_AST_FORMAT_ARG_FORMAT_MODE(AST) ((AST)->format_arg.format_mode)
+#define PKL_AST_FORMAT_ARG_FORMAT_DEPTH(AST) ((AST)->format_arg.format_depth)
+
+#define PKL_AST_FORMAT_MODE_FLAT 0
+#define PKL_AST_FORMAT_MODE_TREE 1
+
+struct pkl_ast_format_arg
+{
+ struct pkl_ast_common common;
+
+ char *begin_sc;
+ char *end_sc;
+ int base;
+ int value_p;
+ int format_mode;
+ int format_depth;
+ char *suffix;
+ union pkl_ast_node *exp;
+};
+
+pkl_ast_node pkl_ast_make_format_arg (pkl_ast ast, pkl_ast_node exp);
+
/* PKL_AST_VAR nodes represent variable references.
NAME is a PKL_AST_IDENTIFIER containing the name used to refer to
@@ -1891,6 +1989,8 @@ union pkl_ast_node
struct pkl_ast_funcall_arg funcall_arg;
struct pkl_ast_var var;
struct pkl_ast_lambda lambda;
+ struct pkl_ast_format format;
+ struct pkl_ast_format_arg format_arg;
struct pkl_ast_incrdecr incrdecr;
/* Types. */
struct pkl_ast_type type;
diff --git a/libpoke/pkl-gen.c b/libpoke/pkl-gen.c
index 19d7fb9e..4abe18d7 100644
--- a/libpoke/pkl-gen.c
+++ b/libpoke/pkl-gen.c
@@ -1408,6 +1408,192 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_ps_exp_stmt)
}
PKL_PHASE_END_HANDLER
+/*
+ * FORMAT
+ * | ARG
+ * | ...
+ */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_format)
+{
+ pkl_ast_node format = PKL_PASS_NODE;
+ pkl_ast_node format_args = PKL_AST_FORMAT_ARGS (format);
+ pkl_ast_node arg;
+ char *prefix = PKL_AST_FORMAT_PREFIX (format);
+ int nstr = 0;
+ /* XXX this hard limit should go away.
+ See pkl-tran.c:pkl_trans1_ps_format. */
+#define MAX_CLASS_TAGS 32
+ int nclasses = 0;
+ struct
+ {
+ char *name;
+ int index;
+ } classes[MAX_CLASS_TAGS];
+
+ /* Save all the intermediate strings in an array of strings and at the
+ end, concatenate all of elements into a single string on the stack. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_string_type ());
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, PVM_NULL);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_MKTYA);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_ulong (0, 64)); /* FIXME use better hint */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_MKA);
+
+ if (prefix)
+ {
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_ulong (0, 64));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_string (prefix));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_AINS);
+ ++nstr;
+ }
+
+ for (arg = format_args; arg; arg = PKL_AST_CHAIN (arg))
+ {
+ pkl_ast_node exp = PKL_AST_FORMAT_ARG_EXP (arg);
+ char *begin_sc = PKL_AST_FORMAT_ARG_BEGIN_SC (arg);
+ char *end_sc = PKL_AST_FORMAT_ARG_END_SC (arg);
+ char *suffix = PKL_AST_FORMAT_ARG_SUFFIX (arg);
+ int base = PKL_AST_FORMAT_ARG_BASE (arg);
+ pkl_ast_node exp_type;
+ int arg_omode;
+ int arg_odepth;
+
+ if (begin_sc)
+ {
+ assert (nclasses < MAX_CLASS_TAGS);
+ classes[nclasses].name = begin_sc;
+ classes[nclasses].index = nstr;
+ ++nclasses;
+ }
+
+ if (end_sc)
+ {
+ char* cname;
+ int cindex, n;
+ pvm_val idx;
+
+ assert (nclasses > 0);
+ --nclasses;
+ cname = classes[nclasses].name;
+ cindex = classes[nclasses].index;
+
+ assert (strcmp (cname, end_sc) == 0);
+
+ n = nstr - cindex;
+ if (n > 0)
+ {
+ nstr = cindex + 1;
+ idx = pvm_make_ulong (cindex, 64);
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DUP); /* ARR ARR */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, idx); /* ARR ARR IDX */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_ulong (n, 64)); /* ARR ARR IDX
LEN */
+ pkl_asm_call (PKL_GEN_ASM, "_pkl_reduce_string_array"); /* ARR
STR */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SWAP); /* STR ARR */
+
+ for (; n > 1; --n)
+ {
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, idx);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_AREM);
+ }
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, idx); /* STR ARR IDX */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_ROT); /* ARR IDX STR */
+
+ /* Set the string style property. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SEL);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_ulong (0, 64));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SWAP); /* STR 0UL LEN */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_string (cname)); /* STR 0UL LEN CLASS */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SPROPS); /* ARR STR */
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_ASET); /* ARR */
+ }
+ }
+
+ if (!exp)
+ goto fmt_suffix;
+
+ /* Generate code to put the value on the stack. */
+ PKL_PASS_SUBPASS (exp);
+
+ /* Everything except %v. */
+ if (!PKL_AST_FORMAT_ARG_VALUE_P (arg))
+ {
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ base ? pvm_make_int (base, 32) : PVM_NULL);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_FORMAT, PKL_AST_TYPE (exp));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_ulong (nstr++,
64));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SWAP);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_AINS);
+ goto fmt_suffix;
+ }
+
+ /* Generate code to format the value (%v). */
+ exp_type = PKL_AST_TYPE (exp);
+ arg_omode = PKL_AST_FORMAT_ARG_FORMAT_MODE (arg);
+ arg_odepth = PKL_AST_FORMAT_ARG_FORMAT_DEPTH (arg);
+
+ /* Set the argument's own omode and odepth, saving
+ the VM's own. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSHOM); /* OMODE */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_int (arg_omode, 32)); /* OMODE NOMODE */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_POPOM); /* OMODE */
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSHOD); /* OMODE ODEPTH */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_int (arg_odepth, 32)); /* OMODE ODEPTH NODEPTH */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_POPOD); /* OMODE ODEPTH */
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_ROT); /* OMODE ODEPTH EXP */
+
+ /* Format the value. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_int (0, 32)); /* OMODE ODEPTH EXP DEPTH */
+ PKL_GEN_DUP_CONTEXT;
+ PKL_GEN_SET_CONTEXT (PKL_GEN_CTX_IN_FORMATER);
+ PKL_PASS_SUBPASS (exp_type); /* OMODE ODEPTH STR */
+ PKL_GEN_POP_CONTEXT;
+
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_NROT); /* STR OMODE ODEPTH */
+
+ /* Restore the current omode and odepth in the VM. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_POPOD); /* ARR STR OMODE */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_POPOM); /* ARR STR */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_ulong (nstr++, 64)); /* ARR STR IDX */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SWAP); /* ARR IDX STR */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_AINS); /* ARR */
+
+ fmt_suffix:
+ if (suffix)
+ {
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_ulong (nstr++,
64));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_string (suffix));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_AINS);
+ }
+ }
+
+ if (nstr)
+ {
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DUP);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_ulong (0, 64));
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, pvm_make_ulong (nstr, 64));
+ pkl_asm_call (PKL_GEN_ASM, "_pkl_reduce_string_array");
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_NIP);
+ }
+
+ PKL_PASS_BREAK;
+
+#undef MAX_CLASS_TAGS
+}
+PKL_PHASE_END_HANDLER
+
/*
* PRINT_STMT
* | ARG
@@ -1985,6 +2171,12 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_offset)
RAS_MACRO_OFFSET_PRINTER (PKL_PASS_NODE); /* _ */
PKL_PASS_BREAK;
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* VAL DEPTH */
+ RAS_MACRO_OFFSET_FORMATER (PKL_PASS_NODE); /* _ */
+ PKL_PASS_BREAK;
+ }
else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_TYPE))
{
/* Just build an offset type. */
@@ -2735,6 +2927,11 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_ps_type_integral)
/* VAL DEPTH */
RAS_MACRO_INTEGRAL_PRINTER (PKL_PASS_NODE); /* _ */
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* VAL DEPTH */
+ RAS_MACRO_INTEGRAL_FORMATER (PKL_PASS_NODE); /* _ */
+ }
else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_TYPE))
{
pkl_asm_insn (pasm, PKL_INSN_PUSH,
@@ -2849,6 +3046,15 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_function)
pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PRINTS);
PKL_PASS_BREAK;
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* Stack: VAL DEPTH */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP); /* DEPTH is not used. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH,
+ pvm_make_string ("#<closure>"));
+ PKL_PASS_BREAK;
+ }
}
PKL_PHASE_END_HANDLER
@@ -3090,6 +3296,27 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_array)
pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_CALL); /* _ */
PKL_PASS_BREAK;
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* Stack: ARR DEPTH */
+
+ pkl_ast_node array_type = PKL_PASS_NODE;
+ pvm_val formater_closure = PKL_AST_TYPE_A_FORMATER (array_type);
+
+ /* If the array type doesn't have a formater, compile one. */
+ if (formater_closure == PVM_NULL)
+ {
+ RAS_FUNCTION_ARRAY_FORMATER (formater_closure, array_type);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, formater_closure);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PEC);
+ }
+ else
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, formater_closure);
+
+ /* Invoke the formater. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_CALL); /* _ */
+ PKL_PASS_BREAK;
+ }
else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_CONSTRUCTOR))
{
/* Stack: null */
@@ -3246,6 +3473,11 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_ps_type_string)
/* Stack: VAL DEPTH */
RAS_MACRO_STRING_PRINTER; /* _ */
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* Stack: VAL DEPTH */
+ RAS_MACRO_STRING_FORMATER; /* _ */
+ }
else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_TYPE))
pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_MKTYS);
}
@@ -3490,6 +3722,27 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_struct)
pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_CALL); /* _ */
PKL_PASS_BREAK;
}
+ else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_FORMATER))
+ {
+ /* Stack: SCT DEPTH */
+
+ pkl_ast_node struct_type = PKL_PASS_NODE;
+ pvm_val formater_closure = PKL_AST_TYPE_S_FORMATER (struct_type);
+
+ /* If the struct type doesn't have a formater, compile one. */
+ if (formater_closure == PVM_NULL)
+ {
+ RAS_FUNCTION_STRUCT_FORMATER (formater_closure, struct_type);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, formater_closure);
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PEC);
+ }
+ else
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, formater_closure);
+
+ /* Invoke the formater. */
+ pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_CALL); /* _ */
+ PKL_PASS_BREAK;
+ }
else if (PKL_GEN_IN_CTX_P (PKL_GEN_CTX_IN_TYPE))
{
/* Do nothing. See PS hook. */
@@ -4263,6 +4516,7 @@ struct pkl_phase pkl_phase_gen =
PKL_PHASE_PR_HANDLER (PKL_AST_RETURN_STMT, pkl_gen_pr_return_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_RETURN_STMT, pkl_gen_ps_return_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_EXP_STMT, pkl_gen_ps_exp_stmt),
+ PKL_PHASE_PR_HANDLER (PKL_AST_FORMAT, pkl_gen_pr_format),
PKL_PHASE_PR_HANDLER (PKL_AST_PRINT_STMT, pkl_gen_pr_print_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_RAISE_STMT, pkl_gen_ps_raise_stmt),
PKL_PHASE_PR_HANDLER (PKL_AST_TRY_CATCH_STMT, pkl_gen_pr_try_catch_stmt),
diff --git a/libpoke/pkl-gen.h b/libpoke/pkl-gen.h
index 49330460..7147113e 100644
--- a/libpoke/pkl-gen.h
+++ b/libpoke/pkl-gen.h
@@ -111,6 +111,7 @@ typedef struct pkl_gen_payload *pkl_gen_payload;
#define PKL_GEN_CTX_IN_ARRAY_BOUNDER 0x80
#define PKL_GEN_CTX_IN_FUNCALL 0x200
#define PKL_GEN_CTX_IN_TYPE 0x400
+#define PKL_GEN_CTX_IN_FORMATER 0x800
extern struct pkl_phase pkl_phase_gen;
diff --git a/libpoke/pkl-gen.pks b/libpoke/pkl-gen.pks
index 1bd48fd1..60a93d44 100644
--- a/libpoke/pkl-gen.pks
+++ b/libpoke/pkl-gen.pks
@@ -1767,6 +1767,557 @@
drop ; _
.end
+;;; RAS_MACRO_FORMAT_INT_SUFFIX @type
+;;; ( -- STR )
+;;;
+;;; Push the suffix corresponding to the specified integral type
+;;; to the stack.
+;;;
+;;; Macro-arguments:
+;;; @type
+;;; pkl_ast_node with an integral type.
+
+ .macro format_int_suffix @type
+ .let #signed_p = pvm_make_int (PKL_AST_TYPE_I_SIGNED_P (@type), 32)
+ .let #size = pvm_make_ulong (PKL_AST_TYPE_I_SIZE (@type), 64)
+ push #signed_p
+ push #size
+ .call _pkl_format_int_suffix
+ .end
+
+;;; RAS_MACRO_INTEGRAL_FORMATER @type
+;;; ( VAL DEPTH -- STR )
+;;;
+;;; Given an integral value and a depth in the stack, push the
+;;; string representation to the stack.
+;;;
+;;; Macro-arguments:
+;;; @type
+;;; pkl_ast_node with the type of the value in the stack.
+
+ .macro integral_formater @type
+ drop ; VAL
+ pushob ; VAL OBASE
+ ;; Calculate and format the prefix.
+ dup ; VAL OBASE OBASE
+ .call _pkl_base_prefix ; VAL OBASE PREFIX
+ nrot ; PREFIX VAL OBASE
+ ;; Format the value.
+ format @type ; PREFIX STR
+ ;; Push the suffix
+ .e format_int_suffix @type ; PREFIX STR SUFFIX
+ .call _pkl_strcat3 ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "integer" ; STR IDX LEN CLASS
+ sprops ; STR
+ .end
+
+;;; RAS_MACRO_OFFSET_FORMATER @type
+;;; ( VAL DEPTH -- STR )
+;;;
+;;; Given an offset value in the stack and a depth level,
+;;; push the string representation of the offset to the stack.
+;;;
+;;; Macro-arguments:
+;;; @type
+;;; pkl_ast_node with the type of the value in the stack.
+
+ .macro offset_formater @type
+ ;; Format the offset magnitude
+ .let @unit = PKL_AST_TYPE_O_UNIT (@type)
+ .let @base_type = PKL_AST_TYPE_O_BASE_TYPE (@type)
+ swap ; DEPTH VAL
+ ogetm ; DEPTH VAL MAG
+ rot ; VAL MAG DEPTH
+ .c PKL_PASS_SUBPASS (@base_type);
+ ; VAL STR
+ ;; Separator
+ push "#" ; VAL STR #
+ rot ; STR # VAL
+ ;; Format the offset unit.
+ ;; If the unit has a name, use it.
+ ;; Otherwise, format the unit in decimal.
+ .let @unit_type = PKL_AST_TYPE (@unit)
+ ogetu ; STR # VAL UNIT
+ nip ; STR # UNIT
+ dup ; STR # UNIT UNIT
+ .call _pkl_unit_name ; STR # UNIT STR
+ sel ; STR # UNIT STR SEL
+ bzlu .no_unit_name
+ drop ; STR # UNIT STR
+ nip ; STR # STR
+ ba .unit_name_done
+.no_unit_name:
+ drop2 ; STR # UNIT
+ push int<32>10 ; STR # UNIT 10
+ format @unit_type ; STR # STR
+.unit_name_done:
+ .call _pkl_strcat3 ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "offset" ; STR IDX LEN CLASS
+ sprops ; STR
+ .end
+
+;;; RAS_MACRO_STRING_FORMATER
+;;; ( VAL DEPTH -- STR )
+;;;
+;;; Given a string value and a depth in the stack, push the
+;;; the string representation to the stack.
+
+ .macro string_formater
+ drop ; VAL
+ .call _pkl_escape_string; VAL
+ push "\"" ; VAL "
+ swap ; " VAL
+ push "\"" ; " VAL "
+ .call _pkl_strcat3 ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "offset" ; STR IDX LEN CLASS
+ sprops ; STR
+ .end
+
+;;; RAS_MACRO_FORMAT_BOFFSET
+;;; ( ULONG -- STR )
+;;;
+;;; Given a bit-offset in the stack, format it out like a real
+;;; offset in hexadecimal, and push it to the stack .
+
+ .macro format_boffset
+ push int<32>16 ; ULONG 16
+ formatlu 64 ; STR
+ push "0x"
+ swap ; 0x STR
+ sconc
+ nip2 ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "integer" ; STR IDX LEN CLASS
+ sprops ; STR
+ ;; XXX RAS turns "#b" into "(B_arg)"
+ push "#" ; STR #
+ push "b" ; STR # b
+ .call _pkl_strcat3 ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "offset" ; STR IDX LEN CLASS
+ sprops ; STR
+ .end
+
+;;; RAS_FUNCTION_ARRAY_FORMATER @array_type
+;;; ( ARR DEPTH -- STR )
+;;;
+;;; Assemble a function that gets an array value and a depth
+;;; level in the stack and formats the array and push it to
+;;; the stack.
+;;;
+;;; Macro-arguments:
+;;; @array_type
+;;; pkl_ast_node with the type of the array value to print.
+
+ .function array_formater @array_type
+ prolog
+ pushf 1
+ regvar $depth ; ARR
+ sel ; ARR SEL
+ dup
+ regvar $sel
+ ;; Find the number of elems that will be formated: NELEM
+ pushoac ; ARR SEL OACUTOFF
+ bzi .no_cut_off
+ itolu 64
+ nip ; ARR SEL OACUTOFFL
+ ltlu ; ARR SEL OACUTOFFL (SEL<OACUTOFFL)
+ bzi .sel_gte_cutoff
+ nrot ; ARR (SEL<OACUTOFFL) SEL OACUTOFFL
+.sel_gte_cutoff:
+ drop
+ nip ; ARR NELEM
+ push null
+.no_cut_off:
+ drop ; ARR NELEM
+ dup
+ regvar $nelem ; ARR NELEM
+ pushvar $sel
+ eqlu
+ nip2 ; ARR (NELEM==SEL)
+ regvar $no_ellip ; ARR
+ mktys
+ push null
+ mktya ; ARR TYPA
+ push ulong<64>0
+ mka ; ARR SARR
+ push ulong<64>0
+ push "["
+ ains
+ swap ; SARR ARR
+ ;; Iterate on the values stored in the array, formating them
+ ;; in turn.
+ push ulong<64>0 ; SARR ARR IDX
+ dup
+ ;; Temporary variable.
+ regvar $idx
+ .while
+ pushvar $nelem ; SARR ARR IDX NELEM
+ over ; SARR ARR IDX NELEM IDX
+ swap ; SARR ARR IDX IDX NELEM
+ ltlu ; SARR ARR IDX IDX NELEM (IDX<NELEM)
+ nip2 ; SARR ARR IDX (IDX<NELEM)
+ .loop
+ ;; Insert a comma if this is not the first element of the
+ ;; array.
+ push ulong<64>0 ; SARR ARR IDX 0UL
+ eql
+ nip ; SARR ARR IDX (IDX==0UL)
+ bnzi .l1
+ drop ; SARR ARR IDX
+ rot ; ARR IDX SARR
+ sel
+ push ","
+ ains ; ARR IDX SARR
+ nrot ; SARR ARR IDX
+ push null
+.l1:
+ drop ; SARR ARR IDX
+ ;; Now format the array element.
+ .let @array_elem_type = PKL_AST_TYPE_A_ETYPE (@array_type)
+ aref ; SARR ARR IDX EVAL
+ pushvar $depth ; SARR ARR IDX EVAL DEPTH
+ .c PKL_PASS_SUBPASS (@array_elem_type);
+ ; SARR ARR IDX STR
+ swap
+ popvar $idx ; SARR ARR STR
+ rot ; ARR STR SARR
+ sel
+ rot ; ARR SARR SEL STR
+ ains
+ swap ; SARR ARR
+ pushvar $idx
+ ;; Format the element offset if required.
+ pushoo ; SARR ARR IDX OMAPS
+ bzi .l3
+ drop
+ rot ; ARR IDX SARR
+ sel ; ARR IDX SARR SLEN
+ push " @ "
+ ains ; ARR IDX SARR
+ nrot ; SARR ARR IDX
+ arefo ; SARR ARR IDX BOFF
+ .e format_boffset ; SARR ARR IDX STR
+ swap
+ popvar $idx ; SARR ARR STR
+ rot ; ARR STR SARR
+ sel ; ARR STR SARR SLEN
+ rot ; ARR SARR SLEN STR
+ ains ; ARR SARR
+ swap ; SARR ARR
+ pushvar $idx ; SARR ARR IDX
+ push null
+.l3:
+ drop
+ ;; Increase index to process next element.
+ push ulong<64>1
+ addlu
+ nip2 ; SARR ARR (IDX+1)
+ .endloop
+ drop
+ ;; Honor oacutoff.
+ pushvar $no_ellip ; SARR ARR NOELLIP
+ bnzi .push_ket
+ drop
+ push "..."
+ push ulong<64>0
+ push ulong<64>3
+ push "ellipsis"
+ sprops ; SARR ARR ...
+ rot
+ sel ; ARR ... SARR SLEN
+ rot ; ARR SARR SLEN ...
+ ains
+ swap
+ push null
+.push_ket:
+ drop ; SARR ARR
+ swap
+ sel
+ push "]"
+ ains ; ARR SARR
+ ;; Format the array offset if required.
+ pushoo ; ARR SARR OMAPS
+ bzi .done
+ drop
+ sel
+ push " @ "
+ ains
+ swap ; SARR ARR
+ mgeto ; SARR ARR BOFF
+ .e format_boffset ; SARR ARR STR
+ rot ; ARR STR SARR
+ sel ; ARR STR SARR SLEN
+ rot ; ARR SARR SLEN STR
+ ains ; ARR SARR
+ push null
+.done:
+ ;; We are done. Cleanup and bye bye.
+ drop
+ nip ; SARR
+ sel ; SARR SLEN
+ push ulong<64>0 ; SARR SLEN IDX
+ swap ; SARR IDX SLEN
+ .call _pkl_reduce_string_array
+ ; STR
+ sel ; STR LEN
+ push ulong<64>0 ; STR LEN IDX
+ swap ; STR IDX LEN
+ push "array" ; STR IDX LEN CLASS
+ sprops ; STR
+ popf 1
+ return
+ .end
+
+;;; RAS_FUNCTION_STRUCT_FORMATER @struct_type
+;;; ( SCT DEPTH -- STR )
+;;;
+;;; Assemble a function that gets a struct value and a depth
+;;; level in the stack and push the string representation of
+;;; the struct to the stack.
+;;;
+;;; Macro-arguments:
+;;; @struct_type
+;;; pkl_ast_node with the type fo the struct value to format.
+
+ .function struct_formater @struct_type
+ prolog
+ pushf 1
+ regvar $depth ; SCT
+ .let #is_union_p = pvm_make_int(PKL_AST_TYPE_S_UNION_P (@struct_type),
32)
+ ;; Make the string[] which will contain all the formatted struct
+ mktys ; SCT STYP
+ push null
+ mktya ; SCT ATYP
+ push ulong<64>0
+ mka ; SCT SARR
+ swap ; SARR SCT
+ typof ; SARR SCT TYP
+ tysctn ; SARR SCT STR
+ nip
+ bnn .named_struct
+ ;; anonymous struct/union
+ drop
+ push #is_union_p ; SARR SCT INT
+ bnzi .anonymous_union
+ drop
+ push "struct" ; SARR SCT STR
+ ba .named_struct
+.anonymous_union:
+ drop
+ push "union"
+.named_struct:
+ sel
+ push ulong<64>0
+ swap
+ push "struct-type-name" ; SARR SCT STR IDX LEN CLASS
+ sprops ; SARR SCT STR
+ rot ; SCT STR SARR
+ push ulong<64>0 ; SCT STR SARR IDX
+ rot ; SCT SARR IDX STR
+ ains
+ swap ; SARR SCT
+ ;; Stop here if we are past the maximum depth configured in
+ ;; the VM.
+ pushod ; SARR SCT MDEPTH
+ bzi .depth_ok
+ pushvar $depth ; SARR SCT MDEPTH DEPTH
+ lei
+ nip2 ; SARR SCT (MDEPTH<=DEPTH)
+ bzi .depth_ok
+ drop ; SARR SCT
+ push " {...}"
+ rot ; SCT STR SARR
+ sel ; SCT STR SARR IDX
+ rot ; SCT SARR IDX STR
+ ains ; SCT SARR
+ swap
+ ba .body_done
+.depth_ok:
+ drop ; SARR SCT
+ ;; Iterate on the elements stored in the struct, formating them
+ ;; in order.
+ swap ; SCT SARR
+ sel
+ push " {"
+ ains ; SCT SARR
+ swap ; SARR SCT
+ .let @field
+ .c uint64_t i;
+ .c for (i = 0, @field = PKL_AST_TYPE_S_ELEMS (struct_type);
+ .c @field;
+ .c @field = PKL_AST_CHAIN (@field))
+ .c {
+ .c if (PKL_AST_CODE (@field) != PKL_AST_STRUCT_TYPE_FIELD)
+ .c continue;
+ .label .process_struct_field
+ .label .process_next_alternative
+ .label .l1
+ .label .l2
+ .label .l3
+ .let #i = pvm_make_ulong (i, 64)
+ .let @field_name = PKL_AST_STRUCT_TYPE_FIELD_NAME (@field)
+ .let @field_type = PKL_AST_STRUCT_TYPE_FIELD_TYPE (@field)
+ ;; Get the value of this field. If this an union we have to
+ ;; refer to the field by name, and the first one we found is
+ ;; the only one.
+ push #is_union_p
+ bzi .process_struct_field
+ ;; union
+ drop
+ .let #name_str = pvm_make_string (PKL_AST_IDENTIFIER_POINTER
(@field_name))
+ push #name_str ; SARR SCT STR
+ srefnt ; SARR SCT STR EVAL
+ nip ; SARR SCT EVAL
+ bn .process_next_alternative
+ ba .l2
+.process_struct_field:
+ drop
+ push #i ; SARR SCT I
+ srefi ; SARR SCT I EVAL
+ swap ; SARR SCT EVAL I
+ bzlu .l1
+ drop
+ ;; Insert the separator if this is not the first field.
+ rot ; SCT EVAL SARR
+ sel
+ push ","
+ ains ; SCT EVAL SARR
+ ba .l3
+.l1:
+ drop
+.l2:
+ rot ; SCT EVAL SARR
+.l3:
+ ;; Indent if in tree-mode.
+ sel ; SCT EVAL SARR IDX
+ pushvar $depth ; SCT EVAL SARR IDX DEPTH
+ push int<32>1
+ addi
+ nip2 ; SCT EVAL SARR IDX (DEPTH+1)
+ pushoi ; SCT EVAL SARR IDX (DEPTH+1) ISTEP
+ pushom ; SCT EVAL SARR IDX DEPTH ISTEP OMODE
+ .call _pkl_indentation ; SCT EVAL SARR IDX STR
+ ains ; SCT EVAL SARR
+ ;; Field name
+ .c if (@field_name)
+ .c {
+ .let #field_name_str = pvm_make_string (PKL_AST_IDENTIFIER_POINTER
(@field_name))
+ sel ; SCT EVAL SARR IDX
+ push #field_name_str
+ sel
+ push ulong<64>0
+ swap
+ push "struct-field-name"
+ sprops ; SCT EVAL SARR IDX STR
+ ains ; SCT EVAL SARR
+ sel
+ push "="
+ ains ; SCT EVAL SARR
+ .c }
+ nrot ; SARR SCT EVAL
+ pushvar $depth ; SARR SCT EVAL DEPTH
+ push int<32>1
+ addi
+ nip2 ; SARR SCT EVAL (DEPTH+1)
+ .c PKL_PASS_SUBPASS (@field_type);
+ ; SARR SCT STR
+ rot ; SCT STR SARR
+ sel ; SCT STR SARR IDX
+ rot ; SCT SARR IDX STR
+ ains ; SCT SARR
+ ;; Format the field offset, if required.
+ .label .no_elem_offset
+ pushoo ; SCT SARR OMAPS
+ bzi .no_elem_offset
+ drop ; SCT SARR
+ sel
+ push " @ " ; SCT SARR IDX STR
+ ains
+ swap ; SARR SCT
+ push #i
+ srefio
+ nip ; SARR SCT BOFF
+ .e format_boffset ; SARR SCT STR
+ rot ; SCT STR SARR
+ sel
+ rot ; SCT SARR IDX STR
+ ains
+ push null ; SCT SARR NULL
+.no_elem_offset:
+ drop
+ swap ; SARR SCT
+ push #is_union_p
+ ;; Unions only have one field => we are done.
+ bnzi .fields_done
+.process_next_alternative:
+ drop ; SARR SCT
+ .c i = i + 1;
+ .c }
+ ba .l4
+.fields_done:
+ drop
+.l4:
+ ;; Indent if in tree-mode.
+ pushvar $depth ; SARR SCT DEPTH
+ pushoi ; SARR SCT DEPTH ISTEP
+ pushom ; SARR SCT DEPTH ISTEP OMODE
+ .call _pkl_indentation ; SARR SCT STR
+ rot ; SCT STR SARR
+ sel ; SCT STR SARR IDX
+ rot ; SCT SARR IDX STR
+ ains
+ sel
+ push "}"
+ ains ; SCT SARR
+ swap
+.body_done:
+ ;; Format the struct offset if required.
+ pushoo ; SARR SCT OMAPS
+ bzi .no_omaps
+ drop ; SARR SCT
+ mgeto
+ nip ; SARR BOFF
+ swap ; BOFF SARR
+ sel ; BOFF SARR IDX
+ push " @ " ; BOFF SARR IDX STR
+ ains ; BOFF SARR
+ sel ; BOFF SARR IDX
+ rot ; SARR IDX BOFF
+ .e format_boffset ; SARR IDX STR
+ ains ; SARR
+ ba .done
+.no_omaps:
+ drop2
+.done:
+ ; SARR
+ sel
+ push ulong<64>0
+ swap ; SARR IDX LEN
+ .call _pkl_reduce_string_array
+ ; STR
+ sel
+ push ulong<64>0
+ swap ; STR IDX LEN
+ push "struct"
+ sprops ; STR
+ popf 1
+ return
+ .end
+
;;; RAS_MACRO_PRINT_INT_SUFFIX @type
;;; ( -- )
;;;
diff --git a/libpoke/pkl-insn.def b/libpoke/pkl-insn.def
index 15a5a32a..5c717417 100644
--- a/libpoke/pkl-insn.def
+++ b/libpoke/pkl-insn.def
@@ -60,9 +60,12 @@ PKL_DEF_INSN(PKL_INSN_PUSH,"v","push")
PKL_DEF_INSN(PKL_INSN_PUSHR,"r","pushr")
PKL_DEF_INSN(PKL_INSN_POPR,"r","popr")
PKL_DEF_INSN(PKL_INSN_DROP,"","drop")
+PKL_DEF_INSN(PKL_INSN_DROP2,"","drop2")
+PKL_DEF_INSN(PKL_INSN_DROP3,"","drop3")
PKL_DEF_INSN(PKL_INSN_SWAP,"","swap")
PKL_DEF_INSN(PKL_INSN_NIP,"","nip")
PKL_DEF_INSN(PKL_INSN_NIP2,"","nip2")
+PKL_DEF_INSN(PKL_INSN_NIP3,"","nip3")
PKL_DEF_INSN(PKL_INSN_DUP,"","dup")
PKL_DEF_INSN(PKL_INSN_OVER,"","over")
PKL_DEF_INSN(PKL_INSN_ROT,"","rot")
@@ -242,6 +245,13 @@ PKL_DEF_INSN(PKL_INSN_SPROPS,"","sprops")
PKL_DEF_INSN(PKL_INSN_SPROPH,"","sproph")
PKL_DEF_INSN(PKL_INSN_SPROPC,"","spropc")
+/* Format instructions. */
+
+PKL_DEF_INSN(PKL_INSN_FORMATI,"n","formati")
+PKL_DEF_INSN(PKL_INSN_FORMATIU,"n","formatiu")
+PKL_DEF_INSN(PKL_INSN_FORMATL,"n","formatl")
+PKL_DEF_INSN(PKL_INSN_FORMATLU,"n","formatlu")
+
/* Offset instructions. */
PKL_DEF_INSN(PKL_INSN_MKO,"","mko")
@@ -548,6 +558,10 @@ PKL_DEF_INSN(PKL_INSN_REV,"n","rev")
PKL_DEF_INSN(PKL_INSN_PRINT,"a","print")
+/* Formating macro-instructions. */
+
+PKL_DEF_INSN(PKL_INSN_FORMAT,"a","format")
+
/*
Local variables:
mode:c
diff --git a/libpoke/pkl-lex.l b/libpoke/pkl-lex.l
index 55ba36cd..38c3b38d 100644
--- a/libpoke/pkl-lex.l
+++ b/libpoke/pkl-lex.l
@@ -227,6 +227,7 @@ S ::
"load" { return LOAD; }
"lambda" { return LAMBDA; }
"assert" { return ASSERT; }
+"format" { return FORMAT; }
"__PKL_BUILTIN_RAND__" {
if (yyextra->bootstrapped) REJECT; return BUILTIN_RAND; }
"__PKL_BUILTIN_GET_ENDIAN__" {
diff --git a/libpoke/pkl-pass.c b/libpoke/pkl-pass.c
index 01adbbdd..e17da587 100644
--- a/libpoke/pkl-pass.c
+++ b/libpoke/pkl-pass.c
@@ -566,6 +566,18 @@ pkl_do_pass_1 (pkl_compiler compiler,
if (PKL_AST_RAISE_STMT_EXP (node))
PKL_PASS (PKL_AST_RAISE_STMT_EXP (node));
break;
+ case PKL_AST_FORMAT_ARG:
+ if (PKL_AST_FORMAT_ARG_EXP (node))
+ PKL_PASS (PKL_AST_FORMAT_ARG_EXP (node));
+ break;
+ case PKL_AST_FORMAT:
+ if (PKL_AST_FORMAT_FMT (node))
+ PKL_PASS (PKL_AST_FORMAT_FMT (node));
+ if (PKL_AST_FORMAT_TYPES (node))
+ PKL_PASS_CHAIN (PKL_AST_FORMAT_TYPES (node));
+ if (PKL_AST_FORMAT_ARGS (node))
+ PKL_PASS_CHAIN (PKL_AST_FORMAT_ARGS (node));
+ break;
case PKL_AST_PRINT_STMT_ARG:
if (PKL_AST_PRINT_STMT_ARG_EXP (node))
PKL_PASS (PKL_AST_PRINT_STMT_ARG_EXP (node));
diff --git a/libpoke/pkl-promo.c b/libpoke/pkl-promo.c
index 786dd956..13e520f8 100644
--- a/libpoke/pkl-promo.c
+++ b/libpoke/pkl-promo.c
@@ -1187,6 +1187,44 @@ PKL_PHASE_BEGIN_HANDLER (pkl_promo_ps_return_stmt)
}
PKL_PHASE_END_HANDLER
+/* Promote arguments to format. */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_promo_ps_format)
+{
+ pkl_ast_node format = PKL_PASS_NODE;
+ pkl_ast_node format_types = PKL_AST_FORMAT_TYPES (format);
+ pkl_ast_node format_args = PKL_AST_FORMAT_ARGS (format);
+
+ pkl_ast_node type, arg;
+
+ for (arg = format_args, type = format_types;
+ arg && type;
+ arg = PKL_AST_CHAIN (arg), type = PKL_AST_CHAIN (type))
+ {
+ pkl_ast_node arg_exp = PKL_AST_FORMAT_ARG_EXP (arg);
+
+ /* Skip arguments without associated values. Also skip
+ arguments with declared type ANY (%v) */
+ if (arg_exp
+ && PKL_AST_TYPE_CODE (type) != PKL_TYPE_ANY)
+ {
+ int restart;
+
+ if (!promote_node (PKL_PASS_AST,
+ &PKL_AST_FORMAT_ARG_EXP (arg),
+ type, &restart))
+ {
+ PKL_ICE (PKL_AST_LOC (arg),
+ "couldn't promote printf argument initializer");
+ PKL_PASS_ERROR;
+ }
+
+ PKL_PASS_RESTART = PKL_PASS_RESTART || restart;
+ }
+ }
+}
+PKL_PHASE_END_HANDLER
+
/* Promote arguments to printf. */
PKL_PHASE_BEGIN_HANDLER (pkl_promo_ps_print_stmt)
@@ -1623,6 +1661,7 @@ struct pkl_phase pkl_phase_promo =
PKL_PHASE_PS_HANDLER (PKL_AST_FUNCALL, pkl_promo_ps_funcall),
PKL_PHASE_PS_HANDLER (PKL_AST_ASS_STMT, pkl_promo_ps_ass_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_RETURN_STMT, pkl_promo_ps_return_stmt),
+ PKL_PHASE_PS_HANDLER (PKL_AST_FORMAT, pkl_promo_ps_format),
PKL_PHASE_PS_HANDLER (PKL_AST_PRINT_STMT, pkl_promo_ps_print_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_IF_STMT, pkl_promo_ps_if_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_LOOP_STMT, pkl_promo_ps_loop_stmt),
diff --git a/libpoke/pkl-rt.pk b/libpoke/pkl-rt.pk
index f8aa32b8..9535f22e 100644
--- a/libpoke/pkl-rt.pk
+++ b/libpoke/pkl-rt.pk
@@ -251,6 +251,74 @@ fun _pkl_base_prefix = (int<32> base) string:
return "";
}
+/* Concatenate three strings. */
+
+fun _pkl_strcat3 = (string a, string b, string c) string:
+ {
+ var la = a'length,
+ lab = la + b'length,
+ labc = lab + c'length,
+ s = "?" * labc;
+
+ __pkl_unsafe_string_set (s, 0, a);
+ __pkl_unsafe_string_set (s, la, b);
+ __pkl_unsafe_string_set (s, lab, c);
+ return s;
+ }
+
+/* Given a DEPTH, indentation step ISTEP and OMODE, returns a string for
+ indentation. */
+
+fun _pkl_indentation = (int<32> depth, int<32> istep, int<32> omode) string:
+ {
+ if (omode != VM_OMODE_TREE)
+ return "";
+
+ var s = " " * (1 + istep * depth);
+
+ __pkl_unsafe_string_set (s, 0, "\n");
+ return s;
+ }
+
+/* Return the suffix corresponding to the integral type with signedness
+ SIGNED_P and size SIZE. */
+
+fun _pkl_format_int_suffix = (int<32> signed_p, uint<64> size) string:
+ {
+ return (signed_p ? "" : "U") +
+ (size == 4 ? "N" :
+ size == 8 ? "B" :
+ size == 16 ? "H" :
+ size == 64 ? "L" : "");
+ }
+
+/* Reduces an array of string to a single string by concatenting the
+ NELEM elements of ARR starting from specified INDEX. */
+
+fun _pkl_reduce_string_array = (string[] arr,
+ uint<64> index, uint<64> nelem) string:
+ {
+ var slen = 0UL,
+ first = index,
+ last = index + nelem;
+
+ while (first < last)
+ {
+ slen += arr[first]'length;
+ ++first;
+ }
+
+ var s = " " * slen; /* Allocate the final string once. */
+
+ first = index;
+ for (var cursor = 0UL; first < last; ++first)
+ {
+ __pkl_unsafe_string_set (s, cursor, arr[first]);
+ cursor += arr[first]'length;
+ }
+ return s;
+ }
+
/* Return a new string in which all the non-printable characters are replaced
with a escape sequence (\xXX). */
diff --git a/libpoke/pkl-tab.y b/libpoke/pkl-tab.y
index 7713191b..1904aaa0 100644
--- a/libpoke/pkl-tab.y
+++ b/libpoke/pkl-tab.y
@@ -422,6 +422,7 @@ token <integer> UNION _("keyword `union'")
%token PRINTF _("keyword `printf'")
%token LOAD _("keyword `load'")
%token LAMBDA _("keyword `lambda'")
+%token FORMAT _("keyword `format'")
%token BUILTIN_RAND BUILTIN_GET_ENDIAN BUILTIN_SET_ENDIAN
%token BUILTIN_GET_IOS BUILTIN_SET_IOS BUILTIN_OPEN BUILTIN_CLOSE
%token BUILTIN_IOSIZE BUILTIN_IOFLAGS BUILTIN_IOGETB BUILTIN_IOSETB
@@ -531,6 +532,7 @@ token <integer> UNION _("keyword `union'")
%type <ast> expression expression_list expression_opt primary
%type <ast> identifier bconc map
%type <ast> funcall funcall_arg_list funcall_arg
+%type <ast> format_arg_list format_arg
%type <ast> array array_initializer_list array_initializer
%type <ast> struct_field_list struct_field
%type <ast> typename type_specifier simple_type_specifier cons_type_specifier
@@ -1176,6 +1178,16 @@ primary:
pkl_ast_finish_returns ($3);
$$ = pkl_ast_make_lambda (pkl_parser->ast, $3);
}
+ | FORMAT '(' STR format_arg_list ')'
+ {
+ $$ = pkl_ast_make_format (pkl_parser->ast, $3, $4);
+ PKL_AST_TYPE ($$)
+ = ASTREF (pkl_ast_make_string_type (pkl_parser->ast));
+ PKL_AST_LOC ($3) = @3;
+ if (PKL_AST_TYPE ($3))
+ PKL_AST_LOC (PKL_AST_TYPE ($3)) = @3;
+ PKL_AST_LOC ($$) = @$;
+ }
| expression INC
{
$$ = pkl_ast_make_incrdecr (pkl_parser->ast, $1,
@@ -1211,13 +1223,35 @@ funcall_arg_list:
funcall_arg:
expression
- {
+ {
$$ = pkl_ast_make_funcall_arg (pkl_parser->ast,
$1, NULL /* name */);
PKL_AST_LOC ($$) = @$;
}
;
+format_arg_list:
+ %empty
+ { $$ = NULL; }
+ | format_arg
+ | format_arg_list ',' expression
+ {
+ pkl_ast_node arg
+ = pkl_ast_make_format_arg (pkl_parser->ast, $3);
+ PKL_AST_LOC (arg) = @3;
+
+ $$ = pkl_ast_chainon ($1, arg);
+ }
+ ;
+
+format_arg:
+ expression
+ {
+ $$ = pkl_ast_make_format_arg (pkl_parser->ast, $1);
+ PKL_AST_LOC ($$) = @$;
+ }
+ ;
+
opt_comma:
%empty
| ','
diff --git a/libpoke/pkl-trans.c b/libpoke/pkl-trans.c
index 2170ac50..a0910bc3 100644
--- a/libpoke/pkl-trans.c
+++ b/libpoke/pkl-trans.c
@@ -643,6 +643,354 @@ PKL_PHASE_BEGIN_HANDLER (pkl_trans1_ps_trimmer)
}
PKL_PHASE_END_HANDLER
+/* Decode format strings in `format' instructions. */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_trans1_ps_format)
+{
+ pkl_ast_node format = PKL_PASS_NODE;
+ pkl_ast_node args = PKL_AST_FORMAT_ARGS (format);
+ pkl_ast_node format_fmt = PKL_AST_FORMAT_FMT (format);
+ char *fmt, *p;
+ pkl_ast_node t, arg;
+ int ntag, nargs = 0;
+ pkl_ast_node types = NULL, prev_arg = NULL;
+ const char *msg = NULL;
+ /* XXX this hard limit should go away. */
+#define MAX_CLASS_TAGS 32
+ int nclasses = 0;
+ char *classes[MAX_CLASS_TAGS];
+
+ /* Calculate the number of arguments. */
+ for (t = args; t; t = PKL_AST_CHAIN (t))
+ nargs++;
+ PKL_AST_FORMAT_NARGS (format) = nargs;
+
+ /* If the format string has been already processed, then we are done. */
+ if (PKL_AST_FORMAT_FMT_PROCESSED_P (format))
+ PKL_PASS_DONE;
+
+ fmt = PKL_AST_STRING_POINTER (format_fmt);
+ p = fmt;
+
+ /* Process the prefix string, if any. */
+ if (*p != '%')
+ {
+ p = strchrnul (fmt, '%');
+ PKL_AST_FORMAT_PREFIX (format) = strndup (fmt, p - fmt);
+ if (!PKL_AST_FORMAT_PREFIX (format))
+ PKL_ICE (PKL_AST_LOC (format), _("out of memory"));
+ }
+
+ /* Process the format string. */
+ prev_arg = NULL;
+ for (types = NULL, ntag = 0, arg = args, nclasses = 0;
+ *p != '\0';
+ prev_arg = arg, arg = PKL_AST_CHAIN (arg))
+ {
+ pkl_ast_node atype;
+ char flag = 0;
+ int prefix = -1;
+
+ assert (*p == '%');
+ if (ntag >= nargs && p[1] != '>' && p[1] != '<')
+ {
+ PKL_ERROR (PKL_AST_LOC (format),
+ "not enough arguments in format");
+ PKL_TRANS_PAYLOAD->errors++;
+ PKL_PASS_ERROR;
+ }
+
+ /* Process the optional numerical prefix. */
+ if (p[1] >= '0' && p[1] <= '9')
+ {
+ prefix = p[1] - '0';
+ p++;
+ }
+
+ /* Process an optional flag (uppercase letter.) */
+ if (p[1] >= 'A' && p[1] <= 'Z')
+ {
+ flag = p[1];
+ p++;
+ }
+
+ /* Make sure this tag supports the given numerical prefix and
+ tag. */
+ if ((flag != 0 || prefix != -1)
+ && p[1] != 'v')
+ {
+ if (flag != 0)
+ msg = _("invalid flag");
+ else
+ msg = _("invalid numerical prefix");
+ goto invalid_tag;
+ }
+
+ /* Now process the rest of the tag. */
+ switch (p[1])
+ {
+ case 'v':
+ p += 2;
+ PKL_AST_FORMAT_ARG_BASE (arg) = 0; /* Arbitrary. */
+ atype = pkl_ast_make_any_type (PKL_PASS_AST);
+ PKL_AST_FORMAT_ARG_VALUE_P (arg) = 1;
+ PKL_AST_FORMAT_ARG_FORMAT_DEPTH (arg)
+ = (prefix == -1 ? 0 : prefix);
+ switch (flag)
+ {
+ case 'T':
+ PKL_AST_FORMAT_ARG_FORMAT_MODE (arg)
+ = PKL_AST_PRINT_MODE_TREE;
+ break;
+ case 'F':
+ /* Fallthrough. */
+ case 0:
+ PKL_AST_FORMAT_ARG_FORMAT_MODE (arg)
+ = PKL_AST_PRINT_MODE_FLAT;
+ break;
+ default:
+ msg = _("invalid flag");
+ goto invalid_tag;
+ }
+ PKL_AST_LOC (atype) = PKL_AST_LOC (format_fmt);
+ types = pkl_ast_chainon (types, atype);
+ ntag++;
+ break;
+ case 's':
+ p += 2;
+ PKL_AST_FORMAT_ARG_BASE (arg) = 10; /* Arbitrary. */
+ atype = pkl_ast_make_string_type (PKL_PASS_AST);
+ PKL_AST_LOC (atype) = PKL_AST_LOC (format_fmt);
+ types = pkl_ast_chainon (types, atype);
+ ntag++;
+ break;
+ case 'c':
+ p += 2;
+ PKL_AST_FORMAT_ARG_BASE (arg) = 256; /* Arbitrary */
+ atype = pkl_ast_make_integral_type (PKL_PASS_AST, 8, 0);
+ PKL_AST_LOC (atype) = PKL_AST_LOC (format_fmt);
+ types = pkl_ast_chainon (types, atype);
+ ntag++;
+ break;
+ case 'i':
+ case 'u':
+ {
+ unsigned int bits;
+
+ if (p[2] >= '0' && p[2] <= '9')
+ {
+ int base_idx;
+
+ if (p[3] >= '0' && p[3] <= '9')
+ {
+ bits = (p[2] - '0') * 10 + (p[3] - '0');
+ base_idx = 4;
+ }
+ else
+ {
+ bits = p[2] - '0';
+ base_idx = 3;
+ }
+
+ if (bits > 64)
+ {
+ msg = _("base with more than 64 bits");
+ goto invalid_tag;
+ }
+
+ switch (p[base_idx])
+ {
+ case 'b': PKL_AST_FORMAT_ARG_BASE (arg) = 2; break;
+ case 'o': PKL_AST_FORMAT_ARG_BASE (arg) = 8; break;
+ case 'd': PKL_AST_FORMAT_ARG_BASE (arg) = 10; break;
+ case 'x': PKL_AST_FORMAT_ARG_BASE (arg) = 16; break;
+ case 'c':
+ PKL_AST_FORMAT_ARG_BASE (arg) = 256;
+ if (bits != 8)
+ {
+ msg = _("char format only makes sense with 8 bits");
+ goto invalid_tag;
+ }
+ break;
+ default:
+ msg = _("invalid base");
+ goto invalid_tag;
+ }
+
+ if (bits == 0)
+ {
+ msg = _("invalid bit-width");
+ goto invalid_tag;
+ }
+ atype = pkl_ast_make_integral_type (PKL_PASS_AST,
+ bits, p[1] == 'i');
+ PKL_AST_LOC (atype) = PKL_AST_LOC (format_fmt);
+ types = pkl_ast_chainon (types, atype);
+
+ if (base_idx == 4)
+ p += 5;
+ else
+ p += 4;
+ }
+ else
+ {
+ if (p[1] == 'u')
+ msg = _("expected decimal digit after %u");
+ else
+ msg = _("expected decimal digit after %i");
+
+ goto invalid_tag;
+ }
+ ntag++;
+ break;
+ }
+ case '<':
+ /* Fallthrough. */
+ case '>':
+ {
+ int end_sc = 0;
+ char *class = xmalloc (strlen (fmt) + 1);
+ size_t j;
+ pkl_ast_node new_arg;
+
+ end_sc = (p[1] == '>');
+ p += 2;
+
+ if (!end_sc)
+ {
+ /* Empty classes are not allowed. */
+ if (*p == ':')
+ {
+ free (class);
+ msg = _("invalid format specifier");
+ goto invalid_tag;
+ }
+
+ /* Get the name of the styling class. */
+ j = 0;
+ while (*p != ':' && *p != '%' && *p != '\0')
+ {
+ class[j++] = *p;
+ p++;
+ }
+ class[j] = '\0';
+
+ if (*p != ':')
+ {
+ free (class);
+ msg = _("invalid format specifier");
+ goto invalid_tag;
+ }
+ p++; /* Skip the : */
+
+ assert (nclasses < MAX_CLASS_TAGS);
+ classes[nclasses++] = class;
+ }
+ else
+ {
+ if (nclasses == 0)
+ {
+ free (class);
+ msg = _("unpaired styling class");
+ goto invalid_tag;
+ }
+ assert (nclasses > 0);
+ class = classes[--nclasses];
+ }
+
+ /* Create the new arg and add it to the list of
+ arguments. */
+ new_arg = pkl_ast_make_format_arg (PKL_PASS_AST,
+ NULL);
+ PKL_AST_LOC (new_arg) = PKL_AST_LOC (format_fmt);
+
+ if (end_sc)
+ PKL_AST_FORMAT_ARG_END_SC (new_arg) = xstrdup (class);
+ else
+ PKL_AST_FORMAT_ARG_BEGIN_SC (new_arg) = class;
+
+ if (arg)
+ {
+ if (arg == PKL_AST_FORMAT_ARGS (format))
+ {
+ /* Prepend. */
+ PKL_AST_CHAIN (new_arg) = arg;
+ PKL_AST_FORMAT_ARGS (format)
+ = ASTREF (new_arg);
+ }
+ else
+ {
+ /* Add after. */
+ PKL_AST_CHAIN (new_arg) = PKL_AST_CHAIN (prev_arg);
+ PKL_AST_CHAIN (prev_arg) = ASTREF (new_arg);
+ }
+ }
+ else
+ {
+ /* Append. */
+ if (!PKL_AST_FORMAT_ARGS (format))
+ PKL_AST_FORMAT_ARGS (format)
+ = ASTREF (new_arg);
+ else
+ PKL_AST_FORMAT_ARGS (format)
+ = pkl_ast_chainon (PKL_AST_FORMAT_ARGS (format),
+ new_arg);
+ }
+
+ arg = new_arg;
+
+ /* The type corresponding to a styling class format
+ directive is `void'. */
+ atype = pkl_ast_make_void_type (PKL_PASS_AST);
+ PKL_AST_LOC (atype) = PKL_AST_LOC (format_fmt);
+ types = pkl_ast_chainon (types, atype);
+
+ break;
+ }
+ default:
+ msg = _("invalid format specifier");
+ goto invalid_tag;
+ }
+
+ /* Add the optional suffix to the argument. */
+ if (*p != '\0' && *p != '%')
+ {
+ char *end = strchrnul (p, '%');
+ PKL_AST_FORMAT_ARG_SUFFIX (arg) = strndup (p, end - p);
+ if (!PKL_AST_FORMAT_ARG_SUFFIX (arg))
+ PKL_ICE (PKL_AST_LOC (format), _("out of memory"));
+ p = end;
+ }
+ }
+
+ /* Check that we are not leaving unclosed styling classes. */
+ if (nclasses > 0)
+ {
+ msg = _("unclosed styling tag");
+ goto invalid_tag;
+ }
+
+ if (nargs > ntag)
+ {
+ PKL_ERROR (PKL_AST_LOC (format),
+ "too many arguments in format");
+ PKL_TRANS_PAYLOAD->errors++;
+ PKL_PASS_ERROR;
+ }
+
+ PKL_AST_FORMAT_TYPES (format) = ASTREF (types);
+
+ PKL_AST_FORMAT_FMT_PROCESSED_P (format) = 1;
+ PKL_PASS_DONE;
+
+ invalid_tag:
+ PKL_ERROR (PKL_AST_LOC (format_fmt),
+ "invalid %%- tag in format string: %s", msg);
+ PKL_TRANS_PAYLOAD->errors++;
+ PKL_PASS_ERROR;
+}
+PKL_PHASE_END_HANDLER
+
/* Decode format strings in `printf' instructions. */
PKL_PHASE_BEGIN_HANDLER (pkl_trans1_ps_print_stmt)
@@ -1163,6 +1511,7 @@ struct pkl_phase pkl_phase_trans1 =
PKL_PHASE_PS_HANDLER (PKL_AST_VAR, pkl_trans1_ps_var),
PKL_PHASE_PS_HANDLER (PKL_AST_FUNC, pkl_trans1_ps_func),
PKL_PHASE_PS_HANDLER (PKL_AST_TRIMMER, pkl_trans1_ps_trimmer),
+ PKL_PHASE_PS_HANDLER (PKL_AST_FORMAT, pkl_trans1_ps_format),
PKL_PHASE_PS_HANDLER (PKL_AST_PRINT_STMT, pkl_trans1_ps_print_stmt),
PKL_PHASE_PR_HANDLER (PKL_AST_DECL, pkl_trans1_pr_decl),
PKL_PHASE_PS_HANDLER (PKL_AST_DECL, pkl_trans1_ps_decl),
diff --git a/libpoke/pkl-typify.c b/libpoke/pkl-typify.c
index 13f530b6..4794a374 100644
--- a/libpoke/pkl-typify.c
+++ b/libpoke/pkl-typify.c
@@ -2240,6 +2240,60 @@ PKL_PHASE_BEGIN_HANDLER
(pkl_typify1_ps_loop_stmt_iterator)
}
PKL_PHASE_END_HANDLER
+/* Type-check `format'. */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_typify1_ps_format)
+{
+ pkl_ast_node format = PKL_PASS_NODE;
+ pkl_ast_node format_args = PKL_AST_FORMAT_ARGS (format);
+ pkl_ast_node format_types = PKL_AST_FORMAT_TYPES (format);
+ pkl_ast_node format_fmt = PKL_AST_FORMAT_FMT (format);
+ pkl_ast_node type;
+ pkl_ast_node arg;
+
+ assert (format_fmt);
+
+ /* Make sure the type of the ARGS match the types in TYPES. */
+
+ for (arg = format_args, type = format_types;
+ arg && type;
+ arg = PKL_AST_CHAIN (arg),
+ type = PKL_AST_CHAIN (type))
+ {
+ pkl_ast_node arg_exp = PKL_AST_FORMAT_ARG_EXP (arg);
+
+ /* Skip arguments without associated values. */
+ if (!arg_exp)
+ continue;
+
+ pkl_ast_node arg_type = PKL_AST_TYPE (arg_exp);
+
+ if (PKL_AST_TYPE_CODE (arg_type) == PKL_TYPE_ANY)
+ {
+ PKL_ERROR (PKL_AST_LOC (arg),
+ "invalid format argument of type `any'");
+ PKL_TYPIFY_PAYLOAD->errors++;
+ PKL_PASS_ERROR;
+ }
+
+ if (!pkl_ast_type_promoteable_p (arg_type, type, 0))
+ {
+ char *found_type = pkl_type_str (arg_type, 1);
+ char *expected_type = pkl_type_str (type, 1);
+
+ PKL_ERROR (PKL_AST_LOC (arg),
+ "format argument is of an invalid type\n\
+expected %s, got %s",
+ expected_type, found_type);
+ free (found_type);
+ free (expected_type);
+ PKL_TYPIFY_PAYLOAD->errors++;
+ PKL_PASS_ERROR;
+ }
+ }
+}
+PKL_PHASE_END_HANDLER
+
/* Type-check `print' and `printf' statements. */
PKL_PHASE_BEGIN_HANDLER (pkl_typify1_ps_print_stmt)
@@ -2901,6 +2955,7 @@ struct pkl_phase pkl_phase_typify1 =
PKL_PHASE_PS_HANDLER (PKL_AST_STRUCT_REF, pkl_typify1_ps_struct_ref),
PKL_PHASE_PS_HANDLER (PKL_AST_LOOP_STMT, pkl_typify1_ps_loop_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_LOOP_STMT_ITERATOR,
pkl_typify1_ps_loop_stmt_iterator),
+ PKL_PHASE_PS_HANDLER (PKL_AST_FORMAT, pkl_typify1_ps_format),
PKL_PHASE_PS_HANDLER (PKL_AST_PRINT_STMT, pkl_typify1_ps_print_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_RAISE_STMT, pkl_typify1_ps_raise_stmt),
PKL_PHASE_PS_HANDLER (PKL_AST_TRY_CATCH_STMT,
pkl_typify1_ps_try_catch_stmt),
diff --git a/libpoke/pvm.jitter b/libpoke/pvm.jitter
index b50530cd..9eb5fde3 100644
--- a/libpoke/pvm.jitter
+++ b/libpoke/pvm.jitter
@@ -67,6 +67,7 @@ end
wrapped-functions
printf
+ snprintf
pvm_array_insert
pvm_array_set
pvm_assert
@@ -701,6 +702,130 @@ late-header-c
JITTER_DROP_STACK (); \
} while (0)
+/* Macros to implement formati* and formatl* instructions. */
+
+#define PVM_FORMATI(OUT,OUTLEN,TYPE,TYPEC,SIGNED_P,BASE) \
+ do \
+ { \
+ TYPEC val = PVM_VAL_##TYPE (JITTER_UNDER_TOP_STACK ()); \
+ char fmt[16]; /* %0NNd */ \
+ char *iformat = ""; \
+ int n; \
+ uint32_t mask \
+ = JITTER_ARGN0 == 32 ? (uint32_t)-1 \
+ : (((uint32_t)1 << JITTER_ARGN0) - 1); \
+ \
+ fmt[0] = '%'; \
+ fmt[1] = '0'; \
+ fmt[2] = '\0'; \
+ if ((BASE) == 10) \
+ { \
+ iformat = SIGNED_P ? PRIi32 : PRIu32; \
+ strcat (fmt, iformat); \
+ } \
+ else \
+ { \
+ char *basefmt = ""; \
+ int prec = 0; \
+ \
+ if ((BASE) == 256) \
+ { \
+ iformat = "c"; \
+ prec = 1; \
+ } \
+ else if ((BASE) == 16) \
+ { \
+ iformat = PRIx32; \
+ prec = (JITTER_ARGN0 / 4) + ((JITTER_ARGN0 % 4) != 0); \
+ } \
+ else if ((BASE) == 8) \
+ { \
+ basefmt = PRIo32; \
+ prec = (JITTER_ARGN0 / 3) + ((JITTER_ARGN0 % 3) != 0); \
+ } \
+ else if ((BASE) == 2) \
+ { \
+ n = pk_format_binary ((OUT), (OUTLEN), val, JITTER_ARGN0, SIGNED_P);\
+ assert (n == 0); \
+ JITTER_DROP_STACK (); \
+ JITTER_DROP_STACK (); \
+ JITTER_PUSH_STACK (pvm_make_string ((OUT))); \
+ break; \
+ } \
+ \
+ assert (prec != 0); \
+ fmt[2] = '0' + (prec / 10); \
+ fmt[3] = '0' + prec - (prec / 10 * 10); \
+ fmt[4] = '\0'; \
+ strcat (fmt, iformat); \
+ strcat (fmt, basefmt); \
+ } \
+ \
+ n = snprintf ((OUT), (OUTLEN), fmt, (BASE) == 10 ? val : val & mask); \
+ assert (n < (OUTLEN)); \
+ JITTER_DROP_STACK (); \
+ JITTER_DROP_STACK (); \
+ JITTER_PUSH_STACK (pvm_make_string ((OUT))); \
+ } while (0)
+
+#define PVM_FORMATL(OUT,OUTLEN,TYPE,TYPEC,SIGNED_P,BASE) \
+ do \
+ { \
+ TYPEC val = PVM_VAL_##TYPE (JITTER_UNDER_TOP_STACK ()); \
+ char fmt[16]; /* %0NNfff */ \
+ char *iformat = ""; \
+ int n; \
+ uint64_t mask \
+ = JITTER_ARGN0 == 64 ? (uint64_t)-1 \
+ : (((uint64_t)1 << JITTER_ARGN0) - 1); \
+ \
+ fmt[0] = '%'; \
+ fmt[1] = '0'; \
+ fmt[2] = '\0'; \
+ if ((BASE) == 10) \
+ { \
+ iformat = SIGNED_P ? PRIi64 : PRIu64; \
+ strcat (fmt, iformat); \
+ } \
+ else \
+ { \
+ char *basefmt = ""; \
+ int prec = 0; \
+ \
+ if ((BASE) == 16) \
+ { \
+ iformat = PRIx64; \
+ prec = (JITTER_ARGN0 / 4) + ((JITTER_ARGN0 % 4) != 0); \
+ } \
+ else if ((BASE) == 8) \
+ { \
+ basefmt = PRIo64; \
+ prec = (JITTER_ARGN0 / 3) + ((JITTER_ARGN0 % 3) != 0); \
+ } \
+ else if ((BASE) == 2) \
+ { \
+ n = pk_format_binary ((OUT), (OUTLEN), val, JITTER_ARGN0, SIGNED_P);\
+ assert (n == 0); \
+ JITTER_DROP_STACK (); \
+ JITTER_DROP_STACK (); \
+ JITTER_PUSH_STACK (pvm_make_string ((OUT))); \
+ break; \
+ } \
+ \
+ fmt[2] = '0' + (prec / 10); \
+ fmt[3] = '0' + prec - (prec / 10 * 10); \
+ fmt[4] = '\0'; \
+ strcat (fmt, iformat); \
+ strcat (fmt, basefmt); \
+ } \
+ \
+ n = snprintf ((OUT), (OUTLEN), fmt, (BASE) == 10 ? val : val & mask); \
+ assert (n < (OUTLEN)); \
+ JITTER_DROP_STACK (); \
+ JITTER_DROP_STACK (); \
+ JITTER_PUSH_STACK (pvm_make_string ((OUT))); \
+ } while (0)
+
end
end
@@ -1970,6 +2095,81 @@ instruction endsc ()
end
end
+
+## Formating Instructions
+
+# In the following instructions the meaning of the argument BASE is
+# the following:
+#
+# 2 - format the number in binary.
+# 8 - format the number in octal.
+# 16 - format the number in hexadecimal.
+# Any other value - format the number in decimal.
+
+# Instruction: formati BITS
+#
+# Given a signed integer and a numeration base in the stack, push the
+# string representation to the stack.
+#
+# Stack: ( INT INT -- STR )
+
+instruction formati (?n)
+ code
+ int base = PVM_VAL_INT (JITTER_TOP_STACK ());
+ char res[32 + 2 /* suffix */ + 1 /* nul */];
+
+ PVM_FORMATI (res, sizeof (res), INT, int32_t, 1 /* signed_p */, base);
+ end
+end
+
+# Instruction: formatiu BITS
+#
+# Given an unsigned integer and a numeration base in the stack, push the
+# string representation to the stack.
+#
+# Stack: ( UINT INT -- STR )
+
+instruction formatiu (?n)
+ code
+ int base = PVM_VAL_INT (JITTER_TOP_STACK ());
+ char res[32 + 2 /* suffix */ + 1 /* nul */];
+
+ PVM_FORMATI (res, sizeof (res), UINT, uint32_t, 0 /* signed_p */, base);
+ end
+end
+
+# Instruction: formatl BITS
+#
+# Given a long and a numeration base in the stack, push the string
+# representation to the stack.
+#
+# Stack: ( LONG INT -- STR )
+
+instruction formatl (?n)
+ code
+ int base = PVM_VAL_INT (JITTER_TOP_STACK ());
+ char res[64 + 2 /* suffix */ + 1 /* nul */];
+
+ PVM_FORMATL (res, sizeof (res), LONG, int64_t, 1 /* signed_p */, base);
+ end
+end
+
+# Instruction: formatlu BITS
+#
+# Given an unsigned long and a numeration base in the stack, push the
+# string representation to the stack.
+#
+# Stack: ( ULONG INT -- STR )
+
+instruction formatlu (?n)
+ code
+ int base = PVM_VAL_INT (JITTER_TOP_STACK ());
+ char res[64 + 2 /* suffix */ + 1 /* nul */];
+
+ PVM_FORMATL (res, sizeof (res), ULONG, uint64_t, 0 /* signed_p */, base);
+ end
+end
+
## Main stack manipulation instructions
@@ -6143,3 +6343,8 @@ rule rot-swap-to-quake rewrite
into
quake
end
+
+rule push-drop-to-nop rewrite
+ push $a; drop
+into
+end
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index a8e8c7ed..f2f4b3a9 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -1027,6 +1027,36 @@ EXTRA_DIST = \
poke.pkl/for-in-4.pk \
poke.pkl/for-in-5.pk \
poke.pkl/for-in-int-struct-1.pk \
+ poke.pkl/format-1.pk \
+ poke.pkl/format-2.pk \
+ poke.pkl/format-3.pk \
+ poke.pkl/format-4.pk \
+ poke.pkl/format-5.pk \
+ poke.pkl/format-6.pk \
+ poke.pkl/format-7.pk \
+ poke.pkl/format-8.pk \
+ poke.pkl/format-9.pk \
+ poke.pkl/format-10.pk \
+ poke.pkl/format-11.pk \
+ poke.pkl/format-12.pk \
+ poke.pkl/format-13.pk \
+ poke.pkl/format-14.pk \
+ poke.pkl/format-15.pk \
+ poke.pkl/format-16.pk \
+ poke.pkl/format-17.pk \
+ poke.pkl/format-18.pk \
+ poke.pkl/format-19.pk \
+ poke.pkl/format-20.pk \
+ poke.pkl/format-21.pk \
+ poke.pkl/format-22.pk \
+ poke.pkl/format-23.pk \
+ poke.pkl/format-24.pk \
+ poke.pkl/format-25.pk \
+ poke.pkl/format-26.pk \
+ poke.pkl/format-27.pk \
+ poke.pkl/format-28.pk \
+ poke.pkl/format-29.pk \
+ poke.pkl/format-diag-1.pk \
poke.pkl/formfeedchar.pk \
poke.pkl/fun-types-1.pk \
poke.pkl/fun-types-2.pk \
@@ -1579,6 +1609,8 @@ EXTRA_DIST = \
poke.pkl/redef-1.pk \
poke.pkl/redef-2.pk \
poke.pkl/redef-3.pk \
+ poke.pkl/reduce-array-1.pk \
+ poke.pkl/reduce-array-2.pk \
poke.pkl/return-1.pk \
poke.pkl/return-2.pk \
poke.pkl/return-diag-1.pk \
diff --git a/testsuite/poke.pkl/format-1.pk b/testsuite/poke.pkl/format-1.pk
new file mode 100644
index 00000000..8188b536
--- /dev/null
+++ b/testsuite/poke.pkl/format-1.pk
@@ -0,0 +1,20 @@
+/* { dg-do run } */
+
+var eq = [
+ format("%i1b", 0) == "0",
+ format("%i8b", 1) == "00000001B",
+ format("%i8b", -1) == "11111111B",
+ format("%u8b", 1) == "00000001UB",
+ format("%u8b", -1) == "11111111UB",
+ format("%i13b", -1 as uint<64>) == "1" * 13,
+ format("%i16b", -1) == "1" * 16 + "H",
+ format("%i16b", 0xa5) == "0" * 8 + "10100101H",
+ format("%i16b", 0xa5) == "0" * 8 + "10100101H",
+ format("%u16b", 0xa5) == "0" * 8 + "10100101UH",
+ format("%i32b", 0xdeadbeaf) == "11011110101011011011111010101111",
+ format("%u32b", 0xdeadbeaf) == "11011110101011011011111010101111",
+ format("%u63b", -1 as uint<64>) == "1" * 63,
+ format("%u64b", -1 as uint<64>) == "1" * 64 + "UL",
+];
+
+for (i in eq) printf ("%i32d", i); /* { dg-output "11111111111111" } */
diff --git a/testsuite/poke.pkl/format-10.pk b/testsuite/poke.pkl/format-10.pk
new file mode 100644
index 00000000..e45b9a15
--- /dev/null
+++ b/testsuite/poke.pkl/format-10.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", 1UB)} } */
+/* { dg-output {"0x01UB"\n} } */
+/* { dg-command {format("%v", 1B)} } */
+/* { dg-output {"0x01B"\n} } */
diff --git a/testsuite/poke.pkl/format-11.pk b/testsuite/poke.pkl/format-11.pk
new file mode 100644
index 00000000..cbd37163
--- /dev/null
+++ b/testsuite/poke.pkl/format-11.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", 1UH)} } */
+/* { dg-output {"0x0001UH"\n} } */
+/* { dg-command {format("%v", 1H)} } */
+/* { dg-output {"0x0001H"\n} } */
diff --git a/testsuite/poke.pkl/format-12.pk b/testsuite/poke.pkl/format-12.pk
new file mode 100644
index 00000000..41cba39d
--- /dev/null
+++ b/testsuite/poke.pkl/format-12.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", 1UL)} } */
+/* { dg-output {"0x0000000000000001UL"\n} } */
+/* { dg-command {format("%v", 1L)} } */
+/* { dg-output {"0x0000000000000001L"\n} } */
diff --git a/testsuite/poke.pkl/format-13.pk b/testsuite/poke.pkl/format-13.pk
new file mode 100644
index 00000000..f4a19f8e
--- /dev/null
+++ b/testsuite/poke.pkl/format-13.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("%v", "Hello")} } */
+/* { dg-output {"\\"Hello\\""} } */
diff --git a/testsuite/poke.pkl/format-14.pk b/testsuite/poke.pkl/format-14.pk
new file mode 100644
index 00000000..911dbe81
--- /dev/null
+++ b/testsuite/poke.pkl/format-14.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("%v", "A\x01B")} } */
+/* { dg-output {"\\"A\\\\x01B\\""} } */
diff --git a/testsuite/poke.pkl/format-15.pk b/testsuite/poke.pkl/format-15.pk
new file mode 100644
index 00000000..e0544e15
--- /dev/null
+++ b/testsuite/poke.pkl/format-15.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("%v", int[]())} } */
+/* { dg-output {"\[]"} } */
diff --git a/testsuite/poke.pkl/format-16.pk b/testsuite/poke.pkl/format-16.pk
new file mode 100644
index 00000000..00c8459d
--- /dev/null
+++ b/testsuite/poke.pkl/format-16.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {format("%v", [1,2,3])} } */
+/* { dg-output {"\[1,2,3]"\n} } */
+/* { dg-command {format("%v", [1UB,2UB,3UB])} } */
+/* { dg-output {"\[1UB,2UB,3UB]"\n} } */
diff --git a/testsuite/poke.pkl/format-17.pk b/testsuite/poke.pkl/format-17.pk
new file mode 100644
index 00000000..f4178e02
--- /dev/null
+++ b/testsuite/poke.pkl/format-17.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", [1,2,3])} } */
+/* { dg-output {"\[0x00000001,0x00000002,0x00000003]"\n} } */
+/* { dg-command {format("%v", [1UB,2UB,3UB])} } */
+/* { dg-output {"\[0x01UB,0x02UB,0x03UB]"\n} } */
diff --git a/testsuite/poke.pkl/format-18.pk b/testsuite/poke.pkl/format-18.pk
new file mode 100644
index 00000000..54116ddb
--- /dev/null
+++ b/testsuite/poke.pkl/format-18.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("%v", ["GNU", "poke"])} } */
+/* { dg-output {"\[\\"GNU\\",\\"poke\\"]"} } */
diff --git a/testsuite/poke.pkl/format-19.pk b/testsuite/poke.pkl/format-19.pk
new file mode 100644
index 00000000..95c72b04
--- /dev/null
+++ b/testsuite/poke.pkl/format-19.pk
@@ -0,0 +1,5 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_oacutoff (4)} } */
+/* { dg-command {format("%v", ["GNU", "poke", "by", "Jose", "Marchesi"])} } */
+/* { dg-output {"\[\\"GNU\\",\\"poke\\",\\"by\\",\\"Jose\\"...]"} } */
diff --git a/testsuite/poke.pkl/format-2.pk b/testsuite/poke.pkl/format-2.pk
new file mode 100644
index 00000000..3ec3c764
--- /dev/null
+++ b/testsuite/poke.pkl/format-2.pk
@@ -0,0 +1,20 @@
+/* { dg-do run } */
+
+var eq = [
+ format("%i1o", 0) == "0",
+ format("%i8o", 0) == "000",
+ format("%i8o", 1) == "001",
+ format("%i8o", -1) == "377",
+ format("%u8o", 1) == "001",
+ format("%u8o", -1) == "377",
+ format("%i13o", -1) == "1" + "7" * 4,
+ format("%i16o", -1) == "1" + "7" * 5,
+ format("%i16o", 0xa5) == "000245",
+ format("%u16o", 0xa5) == "000245",
+ format("%i32o", 0xdeadbeef) == "33653337357",
+ format("%u32o", 0xdeadbeef) == "33653337357",
+ format("%u63o", -1 as uint<64>) == "7" * 21,
+ format("%u64o", -1 as uint<64>) == "1" + "7" * 21,
+];
+
+for (i in eq) printf ("%i32d", i); /* { dg-output "11111111111111" } */
diff --git a/testsuite/poke.pkl/format-20.pk b/testsuite/poke.pkl/format-20.pk
new file mode 100644
index 00000000..debf9214
--- /dev/null
+++ b/testsuite/poke.pkl/format-20.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {vm_set_omaps (1)} } */
+/* { dg-command {vm_set_oacutoff (3)} } */
+/* { dg-command {format("%v", ["GNU", "poke", "by", "Jose", "Marchesi"])} } */
+/* { dg-output {"\[\\"GNU\\" @ 0x0000000000000000#b,\\"poke\\" @
0x0000000000000020#b,\\"by\\" @ 0x0000000000000048#b...] @
0x0000000000000000#b"} } */
diff --git a/testsuite/poke.pkl/format-21.pk b/testsuite/poke.pkl/format-21.pk
new file mode 100644
index 00000000..7717ffd5
--- /dev/null
+++ b/testsuite/poke.pkl/format-21.pk
@@ -0,0 +1,5 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {format("%v", E_generic)} } */
+/* { dg-output {"Exception {code=0,msg=\\"generic\\",exit_status=1}"} } */
diff --git a/testsuite/poke.pkl/format-22.pk b/testsuite/poke.pkl/format-22.pk
new file mode 100644
index 00000000..cfd3f371
--- /dev/null
+++ b/testsuite/poke.pkl/format-22.pk
@@ -0,0 +1,5 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {format("%Fv", E_generic)} } */
+/* { dg-output {"Exception {code=0,msg=\\"generic\\",exit_status=1}"} } */
diff --git a/testsuite/poke.pkl/format-23.pk b/testsuite/poke.pkl/format-23.pk
new file mode 100644
index 00000000..90f05bff
--- /dev/null
+++ b/testsuite/poke.pkl/format-23.pk
@@ -0,0 +1,5 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {format("%Tv", E_generic)} } */
+/* { dg-output {"Exception {\\n code=0,\\n msg=\\"generic\\",\\n
exit_status=1\\n}"} } */
diff --git a/testsuite/poke.pkl/format-24.pk b/testsuite/poke.pkl/format-24.pk
new file mode 100644
index 00000000..f29672c0
--- /dev/null
+++ b/testsuite/poke.pkl/format-24.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {vm_set_oindent (4)} } */
+/* { dg-command {format("%Tv", E_generic)} } */
+/* { dg-output {"Exception {\\n code=0,\\n msg=\\"generic\\",\\n
exit_status=1\\n}"} } */
diff --git a/testsuite/poke.pkl/format-25.pk b/testsuite/poke.pkl/format-25.pk
new file mode 100644
index 00000000..558cc487
--- /dev/null
+++ b/testsuite/poke.pkl/format-25.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {vm_set_oindent (4)} } */
+/* { dg-command {vm_set_omode (VM_OMODE_TREE)} } */ /* No effect. */
+/* { dg-command {format("%v", E_generic)} } */
+/* { dg-output {"Exception
{code=0x00000000,msg=\\"generic\\",exit_status=0x00000001}"} } */
diff --git a/testsuite/poke.pkl/format-26.pk b/testsuite/poke.pkl/format-26.pk
new file mode 100644
index 00000000..7b9dab56
--- /dev/null
+++ b/testsuite/poke.pkl/format-26.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+
+type S = struct
+ {
+ Exception ex;
+ };
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {vm_set_odepth (1)} } */ /* No effect. */
+/* { dg-command {format("%v", S{})} } */
+/* { dg-output {"S {ex=Exception {code=0,msg=\\"\\",exit_status=0}}"} } */
diff --git a/testsuite/poke.pkl/format-27.pk b/testsuite/poke.pkl/format-27.pk
new file mode 100644
index 00000000..ca2b7089
--- /dev/null
+++ b/testsuite/poke.pkl/format-27.pk
@@ -0,0 +1,10 @@
+/* { dg-do run } */
+
+type S = struct
+ {
+ Exception ex;
+ };
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {format("%1v", S{})} } */
+/* { dg-output {"S {ex=Exception {...}}"} } */
diff --git a/testsuite/poke.pkl/format-28.pk b/testsuite/poke.pkl/format-28.pk
new file mode 100644
index 00000000..c997f938
--- /dev/null
+++ b/testsuite/poke.pkl/format-28.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+
+type S = struct
+ {
+ Exception ex;
+ };
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {vm_set_omaps (1)} } */
+/* { dg-command {format("%1v", S{})} } */
+/* { dg-output {S {ex=Exception {...} @ 0x0000000000000000#b @
0x0000000000000000#b} @ 0x0000000000000000#b} } */
diff --git a/testsuite/poke.pkl/format-29.pk b/testsuite/poke.pkl/format-29.pk
new file mode 100644
index 00000000..0dd27cee
--- /dev/null
+++ b/testsuite/poke.pkl/format-29.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+
+type S = struct
+ {
+ int<32>[] i;
+ };
+
+/* { dg-command {vm_set_obase (10)} } */
+/* { dg-command {var s = S{ i=[1,2,3]} } } */
+/* { dg-command {format("%v", s)} } */
+/* { dg-output {"S {i=\[1,2,3]}"} } */
diff --git a/testsuite/poke.pkl/format-3.pk b/testsuite/poke.pkl/format-3.pk
new file mode 100644
index 00000000..2587cb0d
--- /dev/null
+++ b/testsuite/poke.pkl/format-3.pk
@@ -0,0 +1,20 @@
+/* { dg-do run } */
+
+var eq = [
+ format("%i1d", 0) == "0",
+ format("%i8d", 0) == "0",
+ format("%i8d", 1) == "1",
+ format("%i8d", -1) == "-1",
+ format("%u8d", 1) == "1",
+ format("%u8d", -1) == "255",
+ format("%i13d", -1) == "-1",
+ format("%i16d", -1) == "-1",
+ format("%i16d", 0xa5) == "165",
+ format("%u16d", 0xa5) == "165",
+ format("%i32d", 0xdeadbeef) == "-559038737",
+ format("%u32d", 0xdeadbeef) == "3735928559",
+ format("%u63d", -1 as uint<64>) == "9223372036854775807",
+ format("%u64d", -1 as uint<64>) == "18446744073709551615",
+];
+
+for (i in eq) printf ("%i32d", i); /* { dg-output "11111111111111" } */
diff --git a/testsuite/poke.pkl/format-4.pk b/testsuite/poke.pkl/format-4.pk
new file mode 100644
index 00000000..c926402b
--- /dev/null
+++ b/testsuite/poke.pkl/format-4.pk
@@ -0,0 +1,20 @@
+/* { dg-do run } */
+
+var eq = [
+ format("%i1x", 0) == "0",
+ format("%i8x", 0) == "00",
+ format("%i8x", 1) == "01",
+ format("%i8x", -1) == "ff",
+ format("%u8x", 1) == "01",
+ format("%u8x", -1) == "ff",
+ format("%i13x", -1) == "1" + "f" * 3,
+ format("%i16x", -1) == "ffff",
+ format("%i16x", 0xa5) == "00a5",
+ format("%u16x", 0xa5) == "00a5",
+ format("%i32x", 0xdeadbeef) == "deadbeef",
+ format("%u32x", 0xdeadbeef) == "deadbeef",
+ format("%u63x", -1 as uint<64>) == "7" + "f" * 15,
+ format("%u64x", -1 as uint<64>) == "f" * 16,
+];
+
+for (i in eq) printf ("%i32d", i); /* { dg-output "11111111111111" } */
diff --git a/testsuite/poke.pkl/format-5.pk b/testsuite/poke.pkl/format-5.pk
new file mode 100644
index 00000000..08ce7fa1
--- /dev/null
+++ b/testsuite/poke.pkl/format-5.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("Hello")} } */
+/* { dg-output {"Hello"} } */
diff --git a/testsuite/poke.pkl/format-6.pk b/testsuite/poke.pkl/format-6.pk
new file mode 100644
index 00000000..c99d8009
--- /dev/null
+++ b/testsuite/poke.pkl/format-6.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("Hello, %s!", "World")} } */
+/* { dg-output {"Hello, World!"} } */
diff --git a/testsuite/poke.pkl/format-7.pk b/testsuite/poke.pkl/format-7.pk
new file mode 100644
index 00000000..14b6361b
--- /dev/null
+++ b/testsuite/poke.pkl/format-7.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command {format("%s%s%s", "GNU", "", "poke")} } */
+/* { dg-output {"GNUpoke"} } */
diff --git a/testsuite/poke.pkl/format-8.pk b/testsuite/poke.pkl/format-8.pk
new file mode 100644
index 00000000..902a7980
--- /dev/null
+++ b/testsuite/poke.pkl/format-8.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", 1)} } */
+/* { dg-output {"0x00000001"\n} } */
+/* { dg-command {format("%v", 1U)} } */
+/* { dg-output {"0x00000001U"\n} } */
diff --git a/testsuite/poke.pkl/format-9.pk b/testsuite/poke.pkl/format-9.pk
new file mode 100644
index 00000000..2048bc27
--- /dev/null
+++ b/testsuite/poke.pkl/format-9.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+
+/* { dg-command {vm_set_obase (16)} } */
+/* { dg-command {format("%v", 1UN)} } */
+/* { dg-output {"0x1UN"\n} } */
+/* { dg-command {format("%v", 1N)} } */
+/* { dg-output {"0x1N"\n} } */
diff --git a/testsuite/poke.pkl/format-diag-1.pk
b/testsuite/poke.pkl/format-diag-1.pk
new file mode 100644
index 00000000..b1b84960
--- /dev/null
+++ b/testsuite/poke.pkl/format-diag-1.pk
@@ -0,0 +1,3 @@
+/* { dg-do compile } */
+
+format("%i0b", 0); /* { dg-error "invalid bit-width" } */
diff --git a/testsuite/poke.pkl/reduce-array-1.pk
b/testsuite/poke.pkl/reduce-array-1.pk
new file mode 100644
index 00000000..8f3b2e68
--- /dev/null
+++ b/testsuite/poke.pkl/reduce-array-1.pk
@@ -0,0 +1,7 @@
+/* {dg-run} */
+
+var a = ["Hello", ", ", "World", "!"];
+var s = _pkl_reduce_string_array (a, 0, a'length);
+
+/* { dg-command {s} } */
+/* { dg-output {"Hello, World!"} } */
diff --git a/testsuite/poke.pkl/reduce-array-2.pk
b/testsuite/poke.pkl/reduce-array-2.pk
new file mode 100644
index 00000000..76a8a947
--- /dev/null
+++ b/testsuite/poke.pkl/reduce-array-2.pk
@@ -0,0 +1,7 @@
+/* {dg-run} */
+
+var a = ["aaa", "bb", "c", "", "d"];
+var s = _pkl_reduce_string_array (a, 2, 3);
+
+/* { dg-command {s} } */
+/* { dg-output {"cd"} } */
--
2.31.1
[PATCH 12/12] pvm.jitter: Wrap std string functions, Mohammad-Reza Nabipoor, 2021/05/25
Re: [PATCH 00/12] Add format function, Jose E. Marchesi, 2021/05/27