[git] GnuPG - branch, master, updated. gnupg-2.1.16-78-ge7429b1
by Justus Winter
cvs at cvs.gnupg.org
Thu Dec 8 17:25:37 CET 2016
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "The GNU Privacy Guard".
The branch, master has been updated
via e7429b1ced0c69fa7901f888f8dc25f00fc346a4 (commit)
via 404e8a4136bbbab39df7dd5119841e131998cc15 (commit)
via 01256694f006405c54bc2adef63ef0c8f07da9ee (commit)
via a4a69163d9d7e4d9f3339eb5cda0afb947180b26 (commit)
via fcf5aea44627def43425d03881e20902e7c0331e (commit)
from a75790b74095828f967c012eff7033f570d93077 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e7429b1ced0c69fa7901f888f8dc25f00fc346a4
Author: Justus Winter <justus at g10code.com>
Date: Fri Nov 18 13:36:23 2016 +0100
gpgscm: Better error reporting.
* tests/gpgscm/ffi.scm: Move the customized exception handling and
atexit logic...
* tests/gpgscm/init.scm: ... here.
(throw): Record the current history.
(throw'): New function that is history-aware.
(rethrow): New function.
(*error-hook*): Use the new throw'.
* tests/gpgscm/main.c (load): Fix error handling.
(main): Save and use the 'sc->retcode' as exit code.
* tests/gpgscm/repl.scm (repl): Print call history.
* tests/gpgscm/scheme.c (_Error_1): Make a snapshot of the history,
use it to provide a accurate location of the expression causing the
error at runtime, and hand the history trace to the '*error-hook*'.
(opexe_5): Tag all lists at parse time with the current location.
* tests/gpgscm/tests.scm: Update calls to 'throw', use 'rethrow'.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
index c5f373c..b62fd1f 100644
--- a/tests/gpgscm/ffi.scm
+++ b/tests/gpgscm/ffi.scm
@@ -47,39 +47,3 @@
;; Low-level mechanism to terminate the process.
(ffi-define (_exit status))
-
-;; High-level mechanism to terminate the process is to throw an error
-;; of the form (*interpreter-exit* status). This gives automatic
-;; resource management a chance to clean up.
-(define *interpreter-exit* (gensym))
-(define (throw . x)
- (cond
- ((more-handlers?)
- (apply (pop-handler) x))
- ((and (= 2 (length x)) (equal? *interpreter-exit* (car x)))
- (*run-atexit-handlers*)
- (_exit (cadr x)))
- (else
- (apply error x))))
-(set! *error-hook* throw)
-
-;; Terminate the process returning STATUS to the parent.
-(define (exit status)
- (throw *interpreter-exit* status))
-
-;; A list of functions run at interpreter shutdown.
-(define *atexit-handlers* (list))
-
-;; Execute all these functions.
-(define (*run-atexit-handlers*)
- (unless (null? *atexit-handlers*)
- (let ((proc (car *atexit-handlers*)))
- ;; Drop proc from the list so that it will not get
- ;; executed again even if it raises an exception.
- (set! *atexit-handlers* (cdr *atexit-handlers*))
- (proc)
- (*run-atexit-handlers*))))
-
-;; Register a function to be run at interpreter shutdown.
-(define (atexit proc)
- (set! *atexit-handlers* (cons proc *atexit-handlers*)))
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index b03eb43..04f088c 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -567,7 +567,7 @@
; "Catch" establishes a scope spanning multiple call-frames until
; another "catch" is encountered. Within the recovery expression
; the thrown exception is bound to *error*. Errors can be rethrown
-; using (apply throw *error*).
+; using (rethrow *error*).
;
; Exceptions are thrown with:
;
@@ -588,10 +588,30 @@
(define (more-handlers?)
(pair? *handlers*))
-(define (throw . x)
- (if (more-handlers?)
- (apply (pop-handler) x)
- (apply error x)))
+;; This throws an exception.
+(define (throw message . args)
+ (throw' message args (cdr (*vm-history*))))
+
+;; This is used by the vm to throw exceptions.
+(define (throw' message args history)
+ (cond
+ ((more-handlers?)
+ ((pop-handler) message args history))
+ ((and args (= 2 (length args)) (equal? *interpreter-exit* (car args)))
+ (*run-atexit-handlers*)
+ (quit (cadr args)))
+ (else
+ (display message)
+ (if args (begin
+ (display ": ")
+ (write args)))
+ (newline)
+ (vm-history-print history)
+ (quit 1))))
+
+;; Convenience function to rethrow the error.
+(define (rethrow e)
+ (apply throw' e))
(macro (catch form)
(let ((label (gensym)))
@@ -601,8 +621,38 @@
(pop-handler)
,label)))))
-(define *error-hook* throw)
+;; Make the vm use throw'.
+(define *error-hook* throw')
+
+
+
+;; High-level mechanism to terminate the process is to throw an error
+;; of the form (*interpreter-exit* status). This gives automatic
+;; resource management a chance to clean up.
+(define *interpreter-exit* (gensym))
+
+;; Terminate the process returning STATUS to the parent.
+(define (exit status)
+ (throw "interpreter exit" *interpreter-exit* status))
+
+;; A list of functions run at interpreter shutdown.
+(define *atexit-handlers* (list))
+
+;; Execute all these functions.
+(define (*run-atexit-handlers*)
+ (unless (null? *atexit-handlers*)
+ (let ((proc (car *atexit-handlers*)))
+ ;; Drop proc from the list so that it will not get
+ ;; executed again even if it raises an exception.
+ (set! *atexit-handlers* (cdr *atexit-handlers*))
+ (proc)
+ (*run-atexit-handlers*))))
+
+;; Register a function to be run at interpreter shutdown.
+(define (atexit proc)
+ (set! *atexit-handlers* (cons proc *atexit-handlers*)))
+
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
index 2f77ac5..c96dcf1 100644
--- a/tests/gpgscm/main.c
+++ b/tests/gpgscm/main.c
@@ -150,7 +150,10 @@ load (scheme *sc, char *file_name,
h = fopen (qualified_name, "r");
if (h)
- break;
+ {
+ err = 0;
+ break;
+ }
if (n > 1)
{
@@ -170,23 +173,23 @@ load (scheme *sc, char *file_name,
fprintf (stderr,
"Consider using GPGSCM_PATH to specify the location "
"of the Scheme library.\n");
- return err;
+ goto leave;
}
if (verbose > 1)
fprintf (stderr, "Loading %s...\n", qualified_name);
scheme_load_named_file (sc, h, qualified_name);
fclose (h);
- if (sc->retcode)
+ if (sc->retcode && sc->nesting)
{
- if (sc->nesting)
- fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
- return gpg_error (GPG_ERR_GENERAL);
+ fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
+ err = gpg_error (GPG_ERR_GENERAL);
}
+ leave:
if (file_name != qualified_name)
free (qualified_name);
- return 0;
+ return err;
}
@@ -194,6 +197,7 @@ load (scheme *sc, char *file_name,
int
main (int argc, char **argv)
{
+ int retcode;
gpg_error_t err;
char *argv0;
ARGPARSE_ARGS pargs;
@@ -291,8 +295,9 @@ main (int argc, char **argv)
log_fatal ("%s: %s", script, gpg_strerror (err));
}
+ retcode = sc->retcode;
scheme_load_string (sc, "(*run-atexit-handlers*)");
scheme_deinit (sc);
xfree (sc);
- return EXIT_SUCCESS;
+ return retcode;
}
diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm
index 78b8151..84454dc 100644
--- a/tests/gpgscm/repl.scm
+++ b/tests/gpgscm/repl.scm
@@ -34,7 +34,14 @@
(read (open-input-string next)))))
(if (not (eof-object? c))
(begin
- (catch (echo "Error:" *error*)
+ (catch (begin
+ (display (car *error*))
+ (when (and (cadr *error*)
+ (not (null? (cadr *error*))))
+ (display ": ")
+ (write (cadr *error*)))
+ (newline)
+ (vm-history-print (caddr *error*)))
(echo " ===>" (eval c environment)))
(exit (loop ""))))
(exit (loop next)))))))))
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 60b5a41..3abe12a 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2656,6 +2656,7 @@ static INLINE pointer slot_value_in_env(pointer slot)
static pointer _Error_1(scheme *sc, const char *s, pointer a) {
const char *str = s;
+ pointer history;
#if USE_ERROR_HOOK
pointer x;
pointer hdl=sc->ERROR_HOOK;
@@ -2663,19 +2664,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#if SHOW_ERROR_LINE
char sbuf[STRBUFFSIZE];
+#endif
+
+ history = history_flatten(sc);
+#if SHOW_ERROR_LINE
/* make sure error is not in REPL */
if (sc->load_stack[sc->file_i].kind & port_file &&
sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
- int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
- const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+ pointer tag;
+ const char *fname;
+ int ln;
+
+ if (history != sc->NIL && has_tag(car(history))
+ && (tag = get_tag(sc, car(history)))
+ && is_string(car(tag)) && is_integer(cdr(tag))) {
+ fname = string_value(car(tag));
+ ln = ivalue_unchecked(cdr(tag));
+ } else {
+ fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+ ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+ }
/* should never happen */
if(!fname) fname = "<unknown>";
/* we started from 0 */
ln++;
- snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+ snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
str = (const char*)sbuf;
}
@@ -2684,11 +2700,15 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#if USE_ERROR_HOOK
x=find_slot_in_env(sc,sc->envir,hdl,1);
if (x != sc->NIL) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE,
+ cons(sc, history, sc->NIL)),
+ sc->NIL);
if(a!=0) {
- sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+ sc->code);
} else {
- sc->code = sc->NIL;
- }
+ sc->code = cons(sc, sc->F, sc->code);
+ }
sc->code = cons(sc, mk_string(sc, str), sc->code);
setimmutable(car(sc->code));
sc->code = cons(sc, slot_value_in_env(x), sc->code);
@@ -4808,6 +4828,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
Error_0(sc,"syntax error: illegal dot expression");
} else {
sc->nesting_stack[sc->file_i]++;
+#if USE_TAGS && SHOW_ERROR_LINE
+ {
+ const char *filename =
+ sc->load_stack[sc->file_i].rep.stdio.filename;
+ int lineno =
+ sc->load_stack[sc->file_i].rep.stdio.curr_line;
+
+ s_save(sc, OP_TAG_VALUE,
+ cons(sc, mk_string(sc, filename),
+ cons(sc, mk_integer(sc, lineno), sc->NIL)),
+ sc->NIL);
+ }
+#endif
s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
s_thread_to(sc,OP_RDSEXPR);
}
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index bd51819..bec1922 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -130,7 +130,8 @@
(let ((result (call-with-io what "")))
(if (= 0 (:retcode result))
(:stdout result)
- (throw (list what "failed:" (:stderr result))))))
+ (throw (string-append (stringify what) " failed")
+ (:stderr result)))))
(define (call-popen command input-string)
(let ((result (call-with-io command input-string)))
@@ -246,7 +247,7 @@
(let ((,result-sym
,(if (= 1 (length (cadr form)))
`(catch (begin (close ,(caaadr form))
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))
`(letfd ,(cdadr form) ,@(cddr form)))))
(close ,(caaadr form))
@@ -257,7 +258,7 @@
`(let* ((,cwd-sym (getcwd))
(_ (if ,(cadr form) (chdir ,(cadr form))))
(,result-sym (catch (begin (chdir ,cwd-sym)
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))))
(chdir ,cwd-sym)
,result-sym)))
@@ -281,7 +282,7 @@
(_ (chdir ,tmp-sym))
(,result-sym (catch (begin (chdir ,cwd-sym)
(unlink-recursively ,tmp-sym)
- (apply throw *error*))
+ (rethrow *error*))
,@(cdr form))))
(chdir ,cwd-sym)
(unlink-recursively ,tmp-sym)
@@ -312,7 +313,7 @@
(let ((,result-sym
,(if (= 1 (length (cadr form)))
`(catch (begin (remove-temporary-file ,(caadr form))
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))
`(lettmp ,(cdadr form) ,@(cddr form)))))
(remove-temporary-file ,(caadr form))
commit 404e8a4136bbbab39df7dd5119841e131998cc15
Author: Justus Winter <justus at g10code.com>
Date: Fri Nov 18 10:58:18 2016 +0100
gpgscm: Keep a history of calls for error messages.
* tests/gpgscm/init.scm (vm-history-print): New function.
* tests/gpgscm/opdefines.h: New opcodes 'CALLSTACK_POP', 'APPLY_CODE',
and 'VM_HISTORY'.
* tests/gpgscm/scheme-private.h (struct history): New definition.
(struct scheme): New field 'history'.
* tests/gpgscm/scheme.c (gc): Mark objects in the history.
(history_free): New function.
(history_init): Likewise.
(history_mark): Likewise.
(add_mod): New macro.
(sub_mod): Likewise.
(tailstack_clear): New function.
(callstack_pop): Likewise.
(callstack_push): Likewise.
(tailstack_push): Likewise.
(tailstack_flatten): Likewise.
(callstack_flatten): Likewise.
(history_flatten): Likewise.
(opexe_0): New variable 'callsite', keep track of the expression if it
is a call, implement the new opcodes, record function applications in
the history.
(opexe_6): Implement new opcode.
(scheme_init_custom_alloc): Initialize history.
(scheme_deinit): Free history.
* tests/gpgscm/scheme.h (USE_HISTORY): New macro.
--
This patch makes TinySCHEME keep a history of function calls. This
history can be used to produce helpful error messages. The history
data structure is inspired by MIT/GNU Scheme.
Signed-off-by: Justus Winter <justus at g10code.com>
fu history
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index f8fd71a..b03eb43 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -534,6 +534,28 @@
`(define ,(cadr form)
(call/cc (lambda (return) ,@(cddr form)))))
+;; Print the given history.
+(define (vm-history-print history)
+ (let loop ((n 0) (skip 0) (frames history))
+ (cond
+ ((null? frames)
+ #t)
+ ((> skip 0)
+ (loop 0 (- skip 1) (cdr frames)))
+ (else
+ (let ((f (car frames)))
+ (display n)
+ (display ": ")
+ (let ((tag (get-tag f)))
+ (unless (null? tag)
+ (display (basename (car tag)))
+ (display ":")
+ (display (+ 1 (cdr tag)))
+ (display ": ")))
+ (write f))
+ (newline)
+ (loop (+ n 1) skip (cdr frames))))))
+
;;;; Simple exception handling
;
; Exceptions are caught as follows:
diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h
index a2328fa..2d17720 100644
--- a/tests/gpgscm/opdefines.h
+++ b/tests/gpgscm/opdefines.h
@@ -10,6 +10,10 @@
#endif
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS )
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS )
+#if USE_HISTORY
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CALLSTACK_POP )
+#endif
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY_CODE )
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY )
#if USE_TRACING
_OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY )
@@ -197,4 +201,6 @@
_OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE )
_OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP )
_OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP )
+ _OP_DEF(opexe_6, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY )
+
#undef _OP_DEF
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index 40a4211..7f19a6e 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -62,6 +62,34 @@ struct cell {
} _object;
};
+#if USE_HISTORY
+/* The history is a two-dimensional ring buffer. A donut-shaped data
+ * structure. This data structure is inspired by MIT/GNU Scheme. */
+struct history {
+ /* Number of calls to store. Must be a power of two. */
+ size_t N;
+
+ /* Number of tail-calls to store in each call frame. Must be a
+ * power of two. */
+ size_t M;
+
+ /* Masks for fast index calculations. */
+ size_t mask_N;
+ size_t mask_M;
+
+ /* A vector of size N containing calls. */
+ pointer callstack;
+
+ /* A vector of size N containing vectors of size M containing tail
+ * calls. */
+ pointer tailstacks;
+
+ /* Our current position. */
+ size_t n;
+ size_t *m;
+};
+#endif
+
struct scheme {
/* arrays for segments */
func_alloc malloc;
@@ -88,6 +116,11 @@ pointer envir; /* stack register for current environment */
pointer code; /* register for current code */
pointer dump; /* stack register for next evaluation */
+#if USE_HISTORY
+struct history history; /* we keep track of the call history for
+ * error messages */
+#endif
+
int interactive_repl; /* are we in an interactive REPL? */
struct cell _sink;
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 8cec9cf..60b5a41 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -308,6 +308,14 @@ INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
#define cadddr(p) car(cdr(cdr(cdr(p))))
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
+#if USE_HISTORY
+static pointer history_flatten(scheme *sc);
+static void history_mark(scheme *sc);
+#else
+# define history_mark(SC) (void) 0
+# define history_flatten(SC) (SC)->NIL
+#endif
+
#if USE_CHAR_CLASSIFIERS
static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
@@ -1593,6 +1601,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
mark(sc->args);
mark(sc->envir);
mark(sc->code);
+ history_mark(sc);
dump_stack_mark(sc);
mark(sc->value);
mark(sc->inport);
@@ -2830,10 +2839,236 @@ static INLINE void dump_stack_mark(scheme *sc)
mark(sc->dump);
}
+
+
+#if USE_HISTORY
+
+static void
+history_free(scheme *sc)
+{
+ sc->free(sc->history.m);
+ sc->history.tailstacks = sc->NIL;
+ sc->history.callstack = sc->NIL;
+}
+
+static pointer
+history_init(scheme *sc, size_t N, size_t M)
+{
+ size_t i;
+ struct history *h = &sc->history;
+
+ h->N = N;
+ h->mask_N = N - 1;
+ h->n = N - 1;
+ assert ((N & h->mask_N) == 0);
+
+ h->M = M;
+ h->mask_M = M - 1;
+ assert ((M & h->mask_M) == 0);
+
+ h->callstack = mk_vector(sc, N);
+ if (h->callstack == sc->sink)
+ goto fail;
+
+ h->tailstacks = mk_vector(sc, N);
+ for (i = 0; i < N; i++) {
+ pointer tailstack = mk_vector(sc, M);
+ if (tailstack == sc->sink)
+ goto fail;
+ set_vector_elem(h->tailstacks, i, tailstack);
+ }
+
+ h->m = sc->malloc(N * sizeof *h->m);
+ if (h->m == NULL)
+ goto fail;
+
+ for (i = 0; i < N; i++)
+ h->m[i] = 0;
+
+ return sc->T;
+
+fail:
+ history_free(sc);
+ return sc->F;
+}
+
+static void
+history_mark(scheme *sc)
+{
+ struct history *h = &sc->history;
+ mark(h->callstack);
+ mark(h->tailstacks);
+}
+
+#define add_mod(a, b, mask) (((a) + (b)) & (mask))
+#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask)
+
+static INLINE void
+tailstack_clear(scheme *sc, pointer v)
+{
+ assert(is_vector(v));
+ /* XXX optimize */
+ fill_vector(v, sc->NIL);
+}
+
+static pointer
+callstack_pop(scheme *sc)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ pointer item;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ item = vector_elem(h->callstack, n);
+ /* Clear our frame so that it can be gc'ed and we don't run into it
+ * when walking the history. */
+ set_vector_elem(h->callstack, n, sc->NIL);
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+
+ /* Exit from the frame. */
+ h->n = sub_mod(h->n, 1, h->mask_N);
+
+ return item;
+}
+
+static void
+callstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new frame. */
+ n = h->n = add_mod(n, 1, h->mask_N);
+
+ /* Initialize tail stack. */
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+ h->m[n] = h->mask_M;
+
+ set_vector_elem(h->callstack, n, item);
+}
+
+static void
+tailstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ size_t m = h->m[n];
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new tail frame. */
+ m = h->m[n] = add_mod(m, 1, h->mask_M);
+ set_vector_elem(vector_elem(h->tailstacks, n), m, item);
+}
+
+static pointer
+tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
+ pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->M);
+ assert(n < h->M);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(tailstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* Add us. */
+ acc = cons(sc, frame, acc);
+
+ return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
+ acc);
+}
+
+static pointer
+callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->N);
+ assert(n < h->N);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(h->callstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* First, emit the tail calls. */
+ acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
+ acc);
+
+ /* Then us. */
+ acc = cons(sc, frame, acc);
+
+ return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
+}
+
+static pointer
+history_flatten(scheme *sc)
+{
+ struct history *h = &sc->history;
+ pointer history;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ history = callstack_flatten(sc, h->N, h->n, sc->NIL);
+ if (history == sc->sink)
+ return sc->sink;
+
+ return reverse_in_place(sc, sc->NIL, history);
+}
+
+#undef add_mod
+#undef sub_mod
+
+#else /* USE_HISTORY */
+
+#define history_init(SC, A, B) (void) 0
+#define history_free(SC) (void) 0
+#define callstack_pop(SC) (void) 0
+#define callstack_push(SC, X) (void) 0
+#define tailstack_push(SC, X) (void) 0
+
+#endif /* USE_HISTORY */
+
+
+
#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
pointer x, y;
+ pointer callsite;
switch (op) {
CASE(OP_LOAD): /* load */
@@ -2959,7 +3194,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_APPLY);
} else {
- sc->code = cdr(sc->code);
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->code, sc->NIL);
+ gc_enable(sc);
+ sc->code = cdr(sc->code);
s_thread_to(sc,OP_E1ARGS);
}
@@ -2975,9 +3213,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
- sc->code = car(sc->args);
- sc->args = cdr(sc->args);
- s_thread_to(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY_CODE);
}
#if USE_TRACING
@@ -2989,6 +3225,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
#endif
+#if USE_HISTORY
+ CASE(OP_CALLSTACK_POP): /* pop the call stack */
+ callstack_pop(sc);
+ s_return(sc, sc->value);
+#endif
+
+ CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
+ * record in the history as invoked from
+ * 'car(args)' */
+ free_cons(sc, sc->args, &callsite, &sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ /* Fallthrough. */
+
CASE(OP_APPLY): /* apply 'code' to 'args' */
#if USE_TRACING
if(sc->tracing) {
@@ -3001,6 +3251,18 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
/* fall through */
CASE(OP_REAL_APPLY):
#endif
+#if USE_HISTORY
+ if (op != OP_APPLY_CODE)
+ callsite = sc->code;
+ if (s_get_flag(sc, TAIL_CONTEXT)) {
+ /* We are evaluating a tail call. */
+ tailstack_push(sc, callsite);
+ } else {
+ callstack_push(sc, callsite);
+ s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
+ }
+#endif
+
if (is_proc(sc->code)) {
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
} else if (is_foreign(sc->code))
@@ -4805,6 +5067,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
s_retbool(is_closure(car(sc->args)));
CASE(OP_MACROP): /* macro? */
s_retbool(is_macro(car(sc->args)));
+ CASE(OP_VM_HISTORY): /* *vm-history* */
+ s_return(sc, history_flatten(sc));
default:
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
Error_0(sc,sc->strbuff);
@@ -5235,6 +5499,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
}
}
+ history_init(sc, 8, 8);
+
/* initialization of global pointers to special symbols */
sc->LAMBDA = mk_symbol(sc, "lambda");
sc->QUOTE = mk_symbol(sc, "quote");
@@ -5284,6 +5550,7 @@ void scheme_deinit(scheme *sc) {
dump_stack_free(sc);
sc->envir=sc->NIL;
sc->code=sc->NIL;
+ history_free(sc);
sc->args=sc->NIL;
sc->value=sc->NIL;
if(is_port(sc->inport)) {
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 5e7d90d..8560f7d 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -45,6 +45,7 @@ extern "C" {
# define USE_PLIST 0
# define USE_SMALL_INTEGERS 0
# define USE_TAGS 0
+# define USE_HISTORY 0
#endif
@@ -82,6 +83,12 @@ extern "C" {
# define USE_TAGS 1
#endif
+/* Keep a history of function calls. This enables a feature similar
+ * to stack traces. */
+#ifndef USE_HISTORY
+# define USE_HISTORY 1
+#endif
+
/* To force system errors through user-defined error handling (see *error-hook*) */
#ifndef USE_ERROR_HOOK
# define USE_ERROR_HOOK 1
commit 01256694f006405c54bc2adef63ef0c8f07da9ee
Author: Justus Winter <justus at g10code.com>
Date: Mon Nov 21 17:25:10 2016 +0100
gpgscm: Add flag TAIL_CONTEXT.
* tests/gpgscm/scheme.c (S_FLAG_TAIL_CONTEXT): New macro. This flag
indicates that the interpreter is evaluating an expression in a tail
context (see R5RS, section 3.5).
(opexe_0): Clear and set the flag according to the rules layed out in
R5RS, section 3.5.
(opexe_1): Likewise.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index ab3491b..8cec9cf 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2715,6 +2715,12 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#define S_OP_MASK 0x000000ff
#define S_FLAG_MASK 0xffffff00
+/* Set if the interpreter evaluates an expression in a tail context
+ * (see R5RS, section 3.5). If a function, procedure, or continuation
+ * is invoked while this flag is set, the call is recorded as tail
+ * call in the history buffer. */
+#define S_FLAG_TAIL_CONTEXT 0x00000100
+
/* Set flag F. */
#define s_set_flag(sc, f) \
BEGIN \
@@ -2936,6 +2942,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
/* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
}
} else {
@@ -2949,6 +2956,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
sc->args = cons(sc,sc->code, sc->NIL);
gc_enable(sc);
sc->code = sc->value;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_APPLY);
} else {
sc->code = cdr(sc->code);
@@ -2963,6 +2971,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
sc->code = car(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
@@ -3026,6 +3035,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
sc->code = cdr(closure_code(sc->code));
sc->args = sc->NIL;
+ s_set_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_BEGIN);
} else if (is_continuation(sc->code)) { /* CONTINUATION */
sc->dump = cont_dump(sc->code);
@@ -3138,18 +3148,29 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
CASE(OP_BEGIN): /* begin */
- if (!is_pair(sc->code)) {
- s_return(sc,sc->code);
- }
- if (cdr(sc->code) != sc->NIL) {
- s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
- }
- sc->code = car(sc->code);
- s_thread_to(sc,OP_EVAL);
+ {
+ int last;
+
+ if (!is_pair(sc->code)) {
+ s_return(sc,sc->code);
+ }
+
+ last = cdr(sc->code) == sc->NIL;
+ if (!last) {
+ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
+ }
+ sc->code = car(sc->code);
+ if (! last)
+ /* This is not the end of the list. This is not a tail
+ * position. */
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ }
CASE(OP_IF0): /* if */
s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
CASE(OP_IF1): /* if */
@@ -3179,6 +3200,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
gc_enable(sc);
sc->code = cadar(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
gc_enable(sc);
@@ -3227,6 +3249,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
sc->code = cadaar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
CASE(OP_LET1AST): /* let* (make new frame) */
@@ -3240,6 +3263,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_LET2AST, sc->args, sc->code);
sc->code = cadar(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->code = sc->args;
@@ -3276,6 +3300,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
sc->code = cadar(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_goto(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
@@ -3298,6 +3323,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
}
s_save(sc,OP_COND1, sc->NIL, sc->code);
sc->code = caar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_goto(sc,OP_EVAL);
CASE(OP_COND1): /* cond */
@@ -3322,6 +3348,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
} else {
s_save(sc,OP_COND1, sc->NIL, sc->code);
sc->code = caar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_goto(sc,OP_EVAL);
}
}
@@ -3337,6 +3364,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->T);
}
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
@@ -3347,6 +3376,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->value);
} else {
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
}
@@ -3356,6 +3387,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->F);
}
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
@@ -3366,6 +3399,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->value);
} else {
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
}
@@ -3411,6 +3446,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
CASE(OP_CASE0): /* case */
s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_goto(sc,OP_EVAL);
CASE(OP_CASE1): /* case */
commit a4a69163d9d7e4d9f3339eb5cda0afb947180b26
Author: Justus Winter <justus at g10code.com>
Date: Mon Nov 21 12:38:44 2016 +0100
gpgscm: Add flags to the interpreter.
* tests/gpgscm/scheme-private.h (struct scheme): Add field 'flags'.
* tests/gpgscm/scheme.c (S_OP_MASK): New macro.
(S_FLAG_MASK, s_set_flag, s_clear_flag, s_get_flag): Likewise.
(_s_return): Unpack the encoded opcode and flags.
(s_save): Encode the flags along with the opcode. Use normal
integers to encode the result.
(scheme_init_custom_alloc): Initialize 'op' and 'flags'.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index 2c5c749..40a4211 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -163,6 +163,7 @@ int tok;
int print_flag;
pointer value;
int op;
+unsigned int flags;
void *ext_data; /* For the benefit of foreign functions */
long gensym_cnt;
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index c73a832..ab3491b 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2705,6 +2705,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
# define BEGIN do {
# define END } while (0)
+
+
+/* Flags. The interpreter has a flags field. When the interpreter
+ * pushes a frame to the dump stack, it is encoded with the opcode.
+ * Therefore, we do not use the least significant byte. */
+
+/* Masks used to encode and decode opcode and flags. */
+#define S_OP_MASK 0x000000ff
+#define S_FLAG_MASK 0xffffff00
+
+/* Set flag F. */
+#define s_set_flag(sc, f) \
+ BEGIN \
+ (sc)->flags |= S_FLAG_ ## f; \
+ END
+
+/* Clear flag F. */
+#define s_clear_flag(sc, f) \
+ BEGIN \
+ (sc)->flags &= ~ S_FLAG_ ## f; \
+ END
+
+/* Check if flag F is set. */
+#define s_get_flag(sc, f) \
+ !!((sc)->flags & S_FLAG_ ## f)
+
+
+
/* Bounce back to Eval_Cycle and execute A. */
#define s_goto(sc,a) BEGIN \
sc->op = (int)(a); \
@@ -2757,16 +2785,23 @@ static void dump_stack_free(scheme *sc)
static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
pointer dump = sc->dump;
pointer op;
+ unsigned long v;
sc->value = (a);
if (enable_gc)
gc_enable(sc);
if (dump == sc->NIL)
return sc->NIL;
free_cons(sc, dump, &op, &dump);
- sc->op = ivalue(op);
-#ifndef USE_SMALL_INTEGERS
- free_cell(sc, op);
+ v = (unsigned long) ivalue_unchecked(op);
+ sc->op = (int) (v & S_OP_MASK);
+ sc->flags = v & S_FLAG_MASK;
+#ifdef USE_SMALL_INTEGERS
+ if (v < MAX_SMALL_INTEGER) {
+ /* This is a small integer, we must not free it. */
+ } else
+ /* Normal integer. Recover the cell. */
#endif
+ free_cell(sc, op);
free_cons(sc, dump, &sc->args, &dump);
free_cons(sc, dump, &sc->envir, &dump);
free_cons(sc, dump, &sc->code, &sc->dump);
@@ -2774,12 +2809,13 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
}
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-#define s_save_allocates (4 + mk_small_integer_allocates)
+#define s_save_allocates 5
pointer dump;
+ unsigned long v = sc->flags | ((unsigned long) op);
gc_disable(sc, gc_reservations (s_save));
dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
dump = cons(sc, (args), dump);
- sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump);
+ sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
gc_enable(sc);
}
@@ -5111,6 +5147,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
dump_stack_initialize(sc);
sc->code = sc->NIL;
sc->tracing=0;
+ sc->op = -1;
+ sc->flags = 0;
/* init sc->NIL */
typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
commit fcf5aea44627def43425d03881e20902e7c0331e
Author: Justus Winter <justus at g10code.com>
Date: Fri Nov 18 13:23:11 2016 +0100
gpgscm: Implement tags.
* tests/gpgscm/opdefines.h: Add opcodes to create and retrieve tags.
* tests/gpgscm/scheme.c (T_TAGGED): New macro.
(mk_tagged_value): New function.
(has_tag): Likewise.
(get_tag): Likewise.
(mark): Mark tag.
(opexe_4): Implement new opcodes.
* tests/gpgscm/scheme.h (USE_TAGS): New macro.
--
Tags are similar to property lists, but property lists can only be
attached to symbols. Tags can not be attached to an existing object,
but a tagged copy can be created. Once done, the tag can be
manipulated in constant time.
Using this during parsing will enable us to produce meaningful error
messages.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h
index c7347fd..a2328fa 100644
--- a/tests/gpgscm/opdefines.h
+++ b/tests/gpgscm/opdefines.h
@@ -149,6 +149,11 @@
_OP_DEF(opexe_4, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY )
_OP_DEF(opexe_4, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY )
#endif
+#if USE_TAGS
+ _OP_DEF(opexe_4, NULL, 0, 0, TST_NONE, OP_TAG_VALUE )
+ _OP_DEF(opexe_4, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED )
+ _OP_DEF(opexe_4, "get-tag", 1, 1, TST_ANY, OP_GET_TAG )
+#endif
_OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT )
_OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC )
_OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB )
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 30b5915..c73a832 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -166,6 +166,7 @@ type_to_string (enum scheme_types typ)
#define ADJ 32
#define TYPE_BITS 5
#define T_MASKTYPE 31 /* 0000000000011111 */
+#define T_TAGGED 1024 /* 0000010000000000 */
#define T_FINALIZE 2048 /* 0000100000000000 */
#define T_SYNTAX 4096 /* 0001000000000000 */
#define T_IMMUTABLE 8192 /* 0010000000000000 */
@@ -599,6 +600,59 @@ static long binary_decode(const char *s) {
return x;
}
+
+
+/* Tags are like property lists, but can be attached to arbitrary
+ * values. */
+
+#if USE_TAGS
+
+static pointer
+mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
+{
+ pointer r, t;
+
+ assert(! is_vector(v));
+
+ r = get_consecutive_cells(sc, 2);
+ if (r == sc->sink)
+ return sc->sink;
+
+ memcpy(r, v, sizeof *v);
+ typeflag(r) |= T_TAGGED;
+
+ t = r + 1;
+ typeflag(t) = T_PAIR;
+ car(t) = tag_car;
+ cdr(t) = tag_cdr;
+
+ return r;
+}
+
+static INLINE int
+has_tag(pointer v)
+{
+ return !! (typeflag(v) & T_TAGGED);
+}
+
+static INLINE pointer
+get_tag(scheme *sc, pointer v)
+{
+ if (has_tag(v))
+ return v + 1;
+ return sc->NIL;
+}
+
+#else
+
+#define mk_tagged_value(SC, X, A, B) (X)
+#define has_tag(V) 0
+#define get_tag(SC, V) (SC)->NIL
+
+#endif
+
+
+
/* Allocate a new cell segment but do not make it available yet. */
static int
_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
@@ -1481,6 +1535,9 @@ E2: setmark(p);
mark(p+1+i);
}
}
+ /* Mark tag if p has one. */
+ if (has_tag(p))
+ mark(p + 1);
if (is_atom(p))
goto E6;
/* E4: down car */
@@ -4183,6 +4240,29 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
CASE(OP_SYMBOL_PROPERTY): /* symbol-property */
s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
#endif /* USE_PLIST */
+
+#if USE_TAGS
+ CASE(OP_TAG_VALUE): { /* not exposed */
+ /* This tags sc->value with car(sc->args). Useful to tag
+ * results of opcode evaluations. */
+ pointer a, b, c;
+ free_cons(sc, sc->args, &a, &b);
+ free_cons(sc, b, &b, &c);
+ assert(c == sc->NIL);
+ s_return(sc, mk_tagged_value(sc, sc->value, a, b));
+ }
+
+ CASE(OP_MK_TAGGED): /* make-tagged-value */
+ if (is_vector(car(sc->args)))
+ Error_0(sc, "cannot tag vector");
+ s_return(sc, mk_tagged_value(sc, car(sc->args),
+ car(cadr(sc->args)),
+ cdr(cadr(sc->args))));
+
+ CASE(OP_GET_TAG): /* get-tag */
+ s_return(sc, get_tag(sc, car(sc->args)));
+#endif /* USE_TAGS */
+
CASE(OP_QUIT): /* quit */
if(is_pair(sc->args)) {
sc->retcode=ivalue(car(sc->args));
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 2b5b066..5e7d90d 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -44,6 +44,7 @@ extern "C" {
# define USE_DL 0
# define USE_PLIST 0
# define USE_SMALL_INTEGERS 0
+# define USE_TAGS 0
#endif
@@ -76,6 +77,11 @@ extern "C" {
# define USE_PLIST 0
#endif
+/* If set, then every object can be tagged. */
+#ifndef USE_TAGS
+# define USE_TAGS 1
+#endif
+
/* To force system errors through user-defined error handling (see *error-hook*) */
#ifndef USE_ERROR_HOOK
# define USE_ERROR_HOOK 1
-----------------------------------------------------------------------
Summary of changes:
tests/gpgscm/ffi.scm | 36 ---
tests/gpgscm/init.scm | 84 ++++++-
tests/gpgscm/main.c | 21 +-
tests/gpgscm/opdefines.h | 11 +
tests/gpgscm/repl.scm | 9 +-
tests/gpgscm/scheme-private.h | 34 +++
tests/gpgscm/scheme.c | 500 ++++++++++++++++++++++++++++++++++++++++--
tests/gpgscm/scheme.h | 13 ++
tests/gpgscm/tests.scm | 11 +-
9 files changed, 640 insertions(+), 79 deletions(-)
hooks/post-receive
--
The GNU Privacy Guard
http://git.gnupg.org
More information about the Gnupg-commits
mailing list