#undef ALIGNED_P
#undef CACHE_REGISTER
#undef CHECK_OVERFLOW
-#undef FREE_VARIABLE_REF
#undef FUNC2
#undef INIT
#undef INUM_MAX
relative to the current virtual machine. At some point it will
become "the" virtual machine, and we'll delete this paragraph. As
such, the rest of the comments speak as if there's only one VM.
+ In difference from the old VM, local 0 is the procedure, and the
+ first argument is local 1. At some point in the future we should
+ change the fp to point to the procedure and not to local 1.
<more overview here>
*/
} while (0)
/* Reserve stack space for a frame. Will check that there is sufficient
- stack space for N locals, not including the procedure, in addition to
- 4 words to set up the next frame. Invoke after preparing the new
+ stack space for N locals, including the procedure, in addition to
+ 3 words to set up the next frame. Invoke after preparing the new
frame and setting the fp and ip. */
#define ALLOC_FRAME(n) \
do { \
- SCM *new_sp = vp->sp = fp - 1 + n; \
+ SCM *new_sp = vp->sp = fp - 1 + n - 1; \
CHECK_OVERFLOW (new_sp + 4); \
} while (0)
stack expansion is needed. */
#define RESET_FRAME(n) \
do { \
- vp->sp = fp - 1 + n; \
+ vp->sp = fp - 2 + n; \
} while (0)
/* Compute the number of locals in the frame. This is equal to the
- number of actual arguments when a function is first called. */
+ number of actual arguments when a function is first called, plus
+ one for the function. */
#define FRAME_LOCALS_COUNT() \
- (vp->sp + 1 - fp)
+ (vp->sp + 1 - (fp - 1))
/* Restore registers after returning from a frame. */
#define RESTORE_FRAME() \
case opcode:
#endif
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
+#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
+#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-#define FREE_VARIABLE_REF(i) SCM_RTL_PROGRAM_FREE_VARIABLE_REF (SCM_FRAME_PROGRAM (fp), i)
#define RETURN_ONE_VALUE(ret) \
do { \
fp[-1] = rtl_apply; \
fp[0] = rtl_values; \
fp[1] = vals; \
- RESET_FRAME (2); \
+ RESET_FRAME (3); \
ip = (scm_t_uint32 *) rtl_apply_code; \
goto op_apply; \
} while (0)
base[6] = SCM_PACK (ip); /* ra */
base[7] = program;
fp = vp->fp = &base[8];
- RESET_FRAME (nargs_);
+ RESET_FRAME (nargs_ + 1);
}
apply:
vp->sp++;
while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n));
- LOCAL_SET (0, proc);
fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
continue;
SCM ret;
SYNC_ALL ();
- ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT ());
+ ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
/* halt _:24
*
- * Bring the VM to a halt, returning the single value from r0.
+ * Bring the VM to a halt, returning the single value from slot 1.
*/
VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
{
- SCM ret = LOCAL_REF (0);
+ SCM ret = LOCAL_REF (1);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
/* halt/values _:24
*
- * Bring the VM to a halt, returning all the values on the stack.
+ * Bring the VM to a halt, returning all the values from the MV stack.
*/
VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24))
{
scm_t_ptrdiff n;
- SCM *base;
SCM ret = SCM_EOL;
SYNC_BEFORE_GC();
- base = fp + 4;
- n = FRAME_LOCALS_COUNT ();
- while (n--)
- ret = scm_cons (base[n], ret);
+ /* Boot closure in r0, empty stack from r1 to r4, values from r5. */
+ for (n = FRAME_LOCALS_COUNT () - 1; n >= 5; n--)
+ ret = scm_cons (LOCAL_REF (n), ret);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 4;
+ fp = vp->fp = old_fp + from + 3;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 3 + nargs);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 4 + nargs);
- fp[-1] = old_fp[proc];
- ALLOC_FRAME (nargs);
+ fp[-1] = old_fp[proc - 1];
+ ALLOC_FRAME (nargs + 1);
for (n = 0; n < nargs; n++)
- LOCAL_SET (n, old_fp[ip[3 + n]]);
+ LOCAL_SET (n + 1, old_fp[ip[3 + n] - 1]);
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
- fp[-1] = old_fp[proc];
+ fp[-1] = old_fp[proc - 1];
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
fp[-1] = LOCAL_REF (proc);
/* No need to check for overflow, as the compiler has already
ensured that this frame has enough space. */
- RESET_FRAME (nargs);
+ RESET_FRAME (nargs + 1);
APPLY_HOOK ();
{
scm_t_uint32 nargs;
SCM_UNPACK_RTL_24 (op, nargs);
- RESET_FRAME (nargs);
+ RESET_FRAME (nargs + 1);
fp[-1] = rtl_values;
goto op_values;
}
SCM_UNPACK_RTL_24 (op, ptr_idx);
- pointer = FREE_VARIABLE_REF (ptr_idx);
+ pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS;
VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
scm_t_uint16 cif_idx, ptr_idx;
- SCM cif, pointer, ret;
+ SCM closure, cif, pointer, ret;
SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
- cif = FREE_VARIABLE_REF (cif_idx);
- pointer = FREE_VARIABLE_REF (ptr_idx);
+ closure = LOCAL_REF (0);
+ cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
+ pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
SYNC_IP ();
VM_HANDLE_INTERRUPTS;
SCM_UNPACK_RTL_24 (op, contregs_idx);
- contregs = FREE_VARIABLE_REF (contregs_idx);
+ contregs =
+ SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
SYNC_IP ();
scm_i_check_continuation (contregs);
ALLOC_FRAME (nargs);
for (i = 0; i < list_idx; i++)
- fp[i - 1] = fp[i];
+ LOCAL_SET(i - 1, LOCAL_REF (i));
/* Null out these slots, just in case there are less than 2 elements
in the list. */
- fp[list_idx - 1] = SCM_UNDEFINED;
- fp[list_idx] = SCM_UNDEFINED;
+ LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
+ LOCAL_SET (list_idx, SCM_UNDEFINED);
for (i = 0; i < list_len; i++, list = SCM_CDR (list))
- fp[list_idx - 1 + i] = SCM_CAR (list);
+ LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
APPLY_HOOK ();
fp[-1] = fp[0];
fp[0] = cont;
- RESET_FRAME (1);
+ RESET_FRAME (2);
APPLY_HOOK ();
{
SCM *base = fp;
#if VM_USE_HOOKS
- int nargs = FRAME_LOCALS_COUNT ();
+ int nargs = FRAME_LOCALS_COUNT () - 1;
#endif
/* We don't do much; it's the caller that's responsible for
*
* Ensure that there is space on the stack for NLOCALS local variables,
* setting them all to SCM_UNDEFINED, except those nargs values that
- * were passed as arguments.
+ * were passed as arguments and procedure.
*/
VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24))
{
NEXT (1);
}
- /* free-ref dst:12 src:12
- *
- * Load free variable SRC into local slot DST.
- */
- VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
- {
- scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
- CHECK_FREE_VARIABLE (src);
- LOCAL_SET (dst, FREE_VARIABLE_REF (src));
- NEXT (1);
- }
-
- /* make-closure dst:24 offset:32 _:8 nfree:24 free0:24 0:8 ...
+ /* make-closure dst:24 offset:32 _:8 nfree:24
*
* Make a new closure, and write it to DST. The code for the closure
* will be found at OFFSET words from the current IP. OFFSET is a
- * signed 32-bit integer. The registers for the NFREE free variables
- * follow.
+ * signed 32-bit integer. Space for NFREE free variables will be
+ * allocated.
*/
- VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) | OP_DST)
+ VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
// FIXME: Assert range of nfree?
closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
SCM_SET_CELL_WORD_1 (closure, ip + offset);
+ // FIXME: Elide these initializations?
for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 3]));
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
LOCAL_SET (dst, closure);
- NEXT (nfree + 3);
+ NEXT (3);
}
- /* fix-closure dst:24 _:8 nfree:24 free0:24 0:8 ...
+ /* free-ref dst:12 src:12 _:8 idx:24
*
- * "Fix" a closure. This is used for lambda expressions bound in a
- * <fix>, but which are not always called in tail position. In that
- * case we allocate the closures first, then destructively update their
- * free variables to point to each other. NFREE and the locals FREE0...
- * are as in make-closure.
+ * Load free variable IDX from the closure SRC into local slot DST.
*/
- VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
- scm_t_uint32 dst, nfree, n;
- SCM closure;
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ SCM_UNPACK_RTL_12_12 (op, dst, src);
+ SCM_UNPACK_RTL_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
+ NEXT (2);
+ }
- SCM_UNPACK_RTL_24 (op, dst);
- SCM_UNPACK_RTL_24 (ip[1], nfree);
- closure = LOCAL_REF (dst);
- for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 2]));
- NEXT (nfree + 2);
+ /* free-set! dst:12 src:12 _8 idx:24
+ *
+ * Set free variable IDX from the closure DST to SRC.
+ */
+ VM_DEFINE_OP (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ {
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ SCM_UNPACK_RTL_12_12 (op, dst, src);
+ SCM_UNPACK_RTL_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
+ NEXT (2);
}
(let ((src (recur obj)))
(if src
(list (if (statically-allocatable? obj)
- `(make-non-immediate 0 ,src)
- `(static-ref 0 ,src))
- `(static-set! 0 ,dst ,n))
+ `(make-non-immediate 1 ,src)
+ `(static-ref 1 ,src))
+ `(static-set! 1 ,dst ,n))
'())))
(define (intern obj label)
(cond
(reverse inits))))
((stringbuf? obj) '())
((static-procedure? obj)
- `((make-non-immediate 0 ,label)
- (link-procedure! 0 ,(static-procedure-code obj))))
+ `((make-non-immediate 1 ,label)
+ (link-procedure! 1 ,(static-procedure-code obj))))
((cache-cell? obj) '())
((symbol? obj)
- `((make-non-immediate 0 ,(recur (symbol->string obj)))
- (string->symbol 0 0)
- (static-set! 0 ,label 0)))
+ `((make-non-immediate 1 ,(recur (symbol->string obj)))
+ (string->symbol 1 1)
+ (static-set! 1 ,label 0)))
((string? obj)
- `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
- (static-set! 0 ,label 1)))
+ `((make-non-immediate 1 ,(recur (make-stringbuf obj)))
+ (static-set! 1 ,label 1)))
((keyword? obj)
- `((static-ref 0 ,(recur (keyword->symbol obj)))
- (symbol->keyword 0 0)
- (static-set! 0 ,label 0)))
+ `((static-ref 1 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 1 1)
+ (static-set! 1 ,label 0)))
((number? obj)
- `((make-non-immediate 0 ,(recur (number->string obj)))
- (string->number 0 0)
- (static-set! 0 ,label 0)))
+ `((make-non-immediate 1 ,(recur (number->string obj)))
+ (string->number 1 1)
+ (static-set! 1 ,label 0)))
(else
(error "don't know how to intern" obj))))
(cond
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys?
(asm-start asm) #f))
- (nreq (length req))
+ ;; The procedure itself is in slot 0, in the standard calling
+ ;; convention. For procedure prologues, nreq includes the
+ ;; procedure, so here we add 1.
+ (nreq (1+ (length req)))
(nopt (length opt))
(rest? (->bool rest)))
(set-meta-arities! meta (cons arity (meta-arities meta)))
(let ((label (gensym "init-constants")))
(emit-text asm
`((begin-program ,label ())
- (assert-nargs-ee/locals 0 1)
+ (assert-nargs-ee/locals 1 1)
,@(reverse inits)
- (load-constant 0 ,*unspecified*)
- (return 0)
+ (load-constant 1 ,*unspecified*)
+ (return 1)
(end-program)))
label))))
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 ,val)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 ,val)
+ (return 1)
(end-arity)
(end-program))))
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 bar)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 bar)
+ (return 1)
(end-arity)
(end-program)
(begin-program bar
((name . bar)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))))
;; 2: accum
'((begin-program countdown
((name . countdown)))
- (begin-standard-arity (x) 3 #f)
+ (begin-standard-arity (x) 4 #f)
(br fix-body)
(label loop-head)
- (br-if-= 1 0 out)
- (add 2 1 2)
- (add1 1 1)
+ (br-if-= 2 1 out)
+ (add 3 2 3)
+ (add1 2 2)
(br loop-head)
(label fix-body)
- (load-constant 1 0)
(load-constant 2 0)
+ (load-constant 3 0)
(br loop-head)
(label out)
- (return 2)
+ (return 3)
(end-arity)
(end-program)))))
(sumto 1000))))
;; 2: head
'((begin-program make-accum
((name . make-accum)))
- (begin-standard-arity () 2 #f)
- (load-constant 0 0)
- (box 0 0)
- (make-closure 1 accum (0))
- (return 1)
+ (begin-standard-arity () 3 #f)
+ (load-constant 1 0)
+ (box 1 1)
+ (make-closure 2 accum 1)
+ (free-set! 2 1 0)
+ (return 2)
(end-arity)
(end-program)
(begin-program accum
((name . accum)))
- (begin-standard-arity (x) 3 #f)
- (free-ref 1 0)
- (box-ref 2 1)
- (add 2 2 0)
- (box-set! 1 2)
- (return 2)
+ (begin-standard-arity (x) 4 #f)
+ (free-ref 2 0 0)
+ (box-ref 3 2)
+ (add 3 3 1)
+ (box-set! 2 3)
+ (return 3)
(end-arity)
(end-program)))))
(let ((accum (make-accum)))
(assemble-program
'((begin-program call
((name . call)))
- (begin-standard-arity (f) 1 #f)
- (call 1 0 ())
- (return 1) ;; MVRA from call
- (return 1) ;; RA from call
+ (begin-standard-arity (f) 2 #f)
+ (call 2 1 ())
+ (return 2) ;; MVRA from call
+ (return 2) ;; RA from call
(end-arity)
(end-program)))))
(call (lambda () 42))))
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 2 #f)
- (load-constant 1 3)
- (call 2 0 (1))
- (return 2) ;; MVRA from call
- (return 2) ;; RA from call
+ (begin-standard-arity (f) 3 #f)
+ (load-constant 2 3)
+ (call 3 1 (2))
+ (return 3) ;; MVRA from call
+ (return 3) ;; RA from call
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
(assemble-program
'((begin-program call
((name . call)))
- (begin-standard-arity (f) 1 #f)
- (tail-call 0 0)
+ (begin-standard-arity (f) 2 #f)
+ (tail-call 0 1)
(end-arity)
(end-program)))))
(call (lambda () 3))))
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 2 #f)
- (mov 1 0) ;; R1 <- R0
- (load-constant 0 3) ;; R0 <- 3
- (tail-call 1 1)
+ (begin-standard-arity (f) 3 #f)
+ (mov 2 1) ;; R1 <- R0
+ (load-constant 1 3) ;; R0 <- 3
+ (tail-call 1 2)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (begin-standard-arity () 1 #f)
- (cache-current-module! 0 sqrt-scope)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cache-current-module! 1 sqrt-scope)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
(end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (begin-standard-arity (x) 2 #f)
- (cached-toplevel-ref 1 sqrt-scope sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (cached-toplevel-ref 2 sqrt-scope sqrt)
+ (tail-call 1 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cache-current-module! 0 top-incrementor)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cache-current-module! 1 top-incrementor)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
(end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cached-toplevel-ref 0 top-incrementor *top-val*)
- (add1 0 0)
- (cached-toplevel-set! 0 top-incrementor *top-val*)
- (return/values 0)
+ (begin-standard-arity () 2 #f)
+ (cached-toplevel-ref 1 top-incrementor *top-val*)
+ (add1 1 1)
+ (cached-toplevel-set! 1 top-incrementor *top-val*)
+ (return/values 1)
(end-arity)
(end-program)))))
((make-top-incrementor))
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
(end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (begin-standard-arity (x) 2 #f)
- (cached-module-ref 1 (guile) #t sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (cached-module-ref 2 (guile) #t sqrt)
+ (tail-call 1 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
(end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cached-module-ref 0 (tests rtl) #f *top-val*)
- (add1 0 0)
- (cached-module-set! 0 (tests rtl) #f *top-val*)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cached-module-ref 1 (tests rtl) #f *top-val*)
+ (add1 1 1)
+ (cached-module-set! 1 (tests rtl) #f *top-val*)
+ (return 1)
(end-arity)
(end-program)))))
((make-top-incrementor))
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 3)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 3)
+ (return 1)
(end-arity)
(end-program)))))
(pass-if "program name"
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
(pass-if-equal "#<procedure foo (x y)>"
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity (x y) 2 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity (x y) 3 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-opt-arity (x) (y) z 3 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-opt-arity (x) (y) z 4 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
(procedure-documentation
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
(procedure-properties
(assemble-program
'((begin-program foo ())
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
(procedure-properties
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
HCoop / bpt / guile.git / commitdiff