}
\f
- VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
+/*
+ * Strings
+ */
+
- VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
++VM_DEFINE_FUNCTION (165, string_length, "string-length", 1)
+{
+ ARGS1 (str);
+ if (SCM_LIKELY (scm_is_string (str)))
+ RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_length (str));
+ }
+}
+
++VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2)
+{
+ scm_t_signed_bits i = 0;
+ ARGS2 (str, idx);
+ if (SCM_LIKELY (scm_is_string (str)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < scm_i_string_length (str)))
+ RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_ref (str, idx));
+ }
+}
+
+/* No string-set! instruction, as there is no good fast path there. */
+
+\f
/*
* Vectors and arrays
*/
- VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
-VM_DEFINE_FUNCTION (165, vector_ref, "vector-ref", 2)
++VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1)
+{
+ ARGS1 (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_length (vect));
+ }
+}
+
- VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
++VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
}
}
- VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (166, vector_set, "vector-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
NEXT;
}
- VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
-VM_DEFINE_INSTRUCTION (167, make_array, "make-array", 3, -1, 1)
++VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1)
{
scm_t_uint32 len;
SCM shape, ret;
goto vm_error_not_a_struct; \
}
- VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
-VM_DEFINE_FUNCTION (168, struct_p, "struct?", 1)
++VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
{
ARGS1 (obj);
RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}
- VM_DEFINE_FUNCTION (170, struct_vtable, "struct-vtable", 1)
-VM_DEFINE_FUNCTION (169, struct_vtable, "struct-vtable", 1)
++VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
- VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
-VM_DEFINE_INSTRUCTION (170, make_struct, "make-struct", 2, -1, 1)
++VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
NEXT;
}
- VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
-VM_DEFINE_FUNCTION (171, struct_ref, "struct-ref", 2)
++VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
RETURN (scm_struct_ref (obj, pos));
}
- VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
-VM_DEFINE_FUNCTION (172, struct_set, "struct-set", 3)
++VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
/*
* GOOPS support
*/
- VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
-VM_DEFINE_FUNCTION (173, class_of, "class-of", 1)
++VM_DEFINE_FUNCTION (176, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
}
/* FIXME: No checking whatsoever. */
- VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
-VM_DEFINE_FUNCTION (174, slot_ref, "slot-ref", 2)
++VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
}
/* FIXME: No checking whatsoever. */
- VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (175, slot_set, "slot-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
#define ALIGNED_P(ptr, type) \
- ((scm_t_uintptr) (ptr) % alignof (type) == 0)
+ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
- VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
-VM_DEFINE_FUNCTION (176, bv_u16_ref, "bv-u16-ref", 3)
++VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
- VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3)
-VM_DEFINE_FUNCTION (177, bv_s16_ref, "bv-s16-ref", 3)
++VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
- VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3)
-VM_DEFINE_FUNCTION (178, bv_u32_ref, "bv-u32-ref", 3)
++VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
- VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3)
-VM_DEFINE_FUNCTION (179, bv_s32_ref, "bv-s32-ref", 3)
++VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
- VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3)
-VM_DEFINE_FUNCTION (180, bv_u64_ref, "bv-u64-ref", 3)
++VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
- VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3)
-VM_DEFINE_FUNCTION (181, bv_s64_ref, "bv-s64-ref", 3)
++VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
- VM_DEFINE_FUNCTION (183, bv_f32_ref, "bv-f32-ref", 3)
-VM_DEFINE_FUNCTION (182, bv_f32_ref, "bv-f32-ref", 3)
++VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
- VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3)
-VM_DEFINE_FUNCTION (183, bv_f64_ref, "bv-f64-ref", 3)
++VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
- VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2)
-VM_DEFINE_FUNCTION (184, bv_u8_ref, "bv-u8-ref", 2)
++VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
- VM_DEFINE_FUNCTION (186, bv_s8_ref, "bv-s8-ref", 2)
-VM_DEFINE_FUNCTION (185, bv_s8_ref, "bv-s8-ref", 2)
++VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
- VM_DEFINE_FUNCTION (187, bv_u16_native_ref, "bv-u16-native-ref", 2)
-VM_DEFINE_FUNCTION (186, bv_u16_native_ref, "bv-u16-native-ref", 2)
++VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
- VM_DEFINE_FUNCTION (188, bv_s16_native_ref, "bv-s16-native-ref", 2)
-VM_DEFINE_FUNCTION (187, bv_s16_native_ref, "bv-s16-native-ref", 2)
++VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
- VM_DEFINE_FUNCTION (189, bv_u32_native_ref, "bv-u32-native-ref", 2)
-VM_DEFINE_FUNCTION (188, bv_u32_native_ref, "bv-u32-native-ref", 2)
++VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
- VM_DEFINE_FUNCTION (190, bv_s32_native_ref, "bv-s32-native-ref", 2)
-VM_DEFINE_FUNCTION (189, bv_s32_native_ref, "bv-s32-native-ref", 2)
++VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
- VM_DEFINE_FUNCTION (191, bv_u64_native_ref, "bv-u64-native-ref", 2)
-VM_DEFINE_FUNCTION (190, bv_u64_native_ref, "bv-u64-native-ref", 2)
++VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
- VM_DEFINE_FUNCTION (192, bv_s64_native_ref, "bv-s64-native-ref", 2)
-VM_DEFINE_FUNCTION (191, bv_s64_native_ref, "bv-s64-native-ref", 2)
++VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
- VM_DEFINE_FUNCTION (193, bv_f32_native_ref, "bv-f32-native-ref", 2)
-VM_DEFINE_FUNCTION (192, bv_f32_native_ref, "bv-f32-native-ref", 2)
++VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
- VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2)
-VM_DEFINE_FUNCTION (193, bv_f64_native_ref, "bv-f64-native-ref", 2)
++VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
} \
}
- VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (194, bv_u16_set, "bv-u16-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
- VM_DEFINE_INSTRUCTION (196, bv_s16_set, "bv-s16-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (195, bv_s16_set, "bv-s16-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
- VM_DEFINE_INSTRUCTION (197, bv_u32_set, "bv-u32-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (196, bv_u32_set, "bv-u32-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
- VM_DEFINE_INSTRUCTION (198, bv_s32_set, "bv-s32-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (197, bv_s32_set, "bv-s32-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
- VM_DEFINE_INSTRUCTION (199, bv_u64_set, "bv-u64-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (198, bv_u64_set, "bv-u64-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
- VM_DEFINE_INSTRUCTION (200, bv_s64_set, "bv-s64-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (199, bv_s64_set, "bv-s64-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
- VM_DEFINE_INSTRUCTION (201, bv_f32_set, "bv-f32-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (200, bv_f32_set, "bv-f32-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
- VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (201, bv_f64_set, "bv-f64-set", 0, 4, 0)
++VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
NEXT; \
}
- VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (202, bv_u8_set, "bv-u8-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
- VM_DEFINE_INSTRUCTION (204, bv_s8_set, "bv-s8-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (203, bv_s8_set, "bv-s8-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
- VM_DEFINE_INSTRUCTION (205, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (204, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
- VM_DEFINE_INSTRUCTION (206, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (205, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
- VM_DEFINE_INSTRUCTION (207, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (206, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
- VM_DEFINE_INSTRUCTION (208, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (207, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
#else
BV_INT_SET (s32, int32, 4)
#endif
- VM_DEFINE_INSTRUCTION (209, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (208, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
- VM_DEFINE_INSTRUCTION (210, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (209, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
- VM_DEFINE_INSTRUCTION (211, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (210, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
- VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (211, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
++VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
(define (report-error loc . args)
(apply error args))
- (define (runtime-error loc msg . args)
- (make-primcall loc 'error
- (cons (make-const loc msg) args)))
-
- ;;; Generate code to ensure a global symbol is there for further use of
- ;;; a given symbol. In general during the compilation, those needed are
- ;;; only tracked with the bindings data structure. Afterwards, however,
- ;;; for all those needed symbols the globals are really generated with
- ;;; this routine.
-
- (define (generate-ensure-global loc sym module)
- (make-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
- (define (ensuring-globals loc bindings body)
- (list->seq
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
- ;;; Build a construct that establishes dynamic bindings for certain
- ;;; variables. We may want to choose between binding with fluids and
- ;;; with-fluids* and using just ordinary module symbols and
- ;;; setting/reverting their values with a dynamic-wind.
-
- (define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-primcall loc 'list
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-primcall loc 'list vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
- ;;; Handle access to a variable (reference/setting) correctly depending
- ;;; on whether it is currently lexically or dynamically bound. lexical
- ;;; access is done only for references to the value-slot module!
-
- (define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
- ;;; Generate code to reference a variable. For references in the
- ;;; value-slot module, we may want to generate a lexical reference
- ;;; instead if the variable has a lexical binding.
+ (define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
- (define (reference-variable loc sym module)
+ (define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc
'fluid-ref
- (make-module-ref loc module sym #t)))))
+ (make-module-ref loc value-slot symbol #t)))))
+
+ (define (global? module symbol)
+ (module-variable module symbol))
+
+ (define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
- (make-sequence
++ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc value-slot)
- (make-const loc name))))
++ (make-call loc
++ (make-module-ref loc runtime 'ensure-fluid! #t)
++ (list (make-const loc value-slot)
++ (make-const loc name))))
+ names)
+ ,body))))
+
+ (define (set-variable! loc symbol value)
+ (access-variable
+ loc
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (ensure-globals!
+ loc
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
- ;;; Generate code to set a variable. Just as with reference-variable, in
- ;;; case of a reference to value-slot, we want to generate a lexical set
- ;;; when the variable has a lexical binding.
+ (define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
- (define (set-variable! loc sym module value)
- (access-variable
+ (define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+ (define (set-function! loc symbol value)
+ (access-function
loc
- sym
- module
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
- (make-application
+ (make-call
loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
- ;;; Process the bindings part of a let or let* expression; that is,
- ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
- ;;; . val2) ...).
-
- (define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
-
- ;;; Split the let bindings into a list to be done lexically and one
- ;;; dynamically. A symbol will be bound lexically if and only if: We're
- ;;; processing a lexical-let (i.e. module is 'lexical), OR we're
- ;;; processing a value-slot binding AND the symbol is already lexically
- ;;; bound or is always lexical, OR we're processing a function-slot
- ;;; binding.
-
- (define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq sym always)
- (get-lexical-binding (fluid-ref bindings-data) sym))))))
-
- (define (split-let-bindings bindings module)
- (let iterate ((tail bindings)
- (lexical '())
- (dynamic '()))
- (if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
- ;;; Compile let and let* expressions. The code here is used both for
- ;;; let/let* and flet/flet*, just with a different bindings module.
- ;;;
- ;;; A special module value 'lexical means that we're doing a lexical-let
- ;;; instead and the bindings should not be saved to globals at all but
- ;;; be done with the lexical framework instead.
-
- ;;; Let is done with a single call to let-dynamic binding them locally
- ;;; to new values all "at once". If there is at least one variable to
- ;;; bind lexically among the bindings, we first do a let for all of them
- ;;; to evaluate all values before any bindings take place, and then call
- ;;; let-dynamic for the variables to bind dynamically.
-
- (define (generate-let loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (call-with-values
- (lambda () (split-let-bindings bind module))
- (lambda (lexical dynamic)
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module))
- (map car dynamic))
- (let ((make-values (lambda (for)
- (map (lambda (el) (compile-expr (cdr el)))
- for)))
- (make-body (lambda ()
- (list->seq loc (map compile-expr body)))))
- (if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical)
- (make-values dynamic))))
- (make-let loc
- all-syms
- all-syms
- vals
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc
- (map car dynamic)
- module
- (map
- (lambda (sym)
- (make-lexical-ref loc
- sym
- sym))
- dynamic-syms)
- (make-body)))))))))))))
-
- ;;; Let* is compiled to a cascaded set of "small lets" for each binding
- ;;; in turn so that each one already sees the preceding bindings.
-
- (define (generate-let* loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (begin
- (for-each (lambda (sym)
- (if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module)))
- (map car bind))
- (let iterate ((tail bind))
- (if (null? tail)
- (list->seq loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc
- `(,target)
- `(,target)
- `(,value)
- (with-lexical-bindings
- (fluid-ref bindings-data)
- `(,sym)
- `(,target)
- (lambda () (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail))
- module
- `(,value)
- (iterate (cdr tail))))))))))
-
- ;;; Split the argument list of a lambda expression into required,
- ;;; optional and rest arguments and also check it is actually valid.
- ;;; Additionally, we create a list of all "local variables" (that is,
- ;;; required, optional and rest arguments together) and also this one
- ;;; split into those to be bound lexically and dynamically. Returned is
- ;;; as multiple values: required optional rest lexical dynamic
-
- (define (bind-arg-lexical? arg)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq arg always))))
-
- (define (split-lambda-arguments loc args)
- (let iterate ((tail args)
- (mode 'required)
- (required '())
- (optional '())
- (lexical '())
- (dynamic '()))
- (cond
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse dynamic)))
- (values final-required
- final-optional
- #f
- final-lexical
- final-dynamic)))
- ((and (eq? mode 'required)
- (eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional lexical dynamic))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest dynamic)))))
- (values final-required
- final-optional
- rest
- final-lexical
- final-dynamic))))
- (else
- (if (not (symbol? (car tail)))
- (report-error loc
- "expected symbol in argument list, got"
- (car tail))
- (let* ((arg (car tail))
- (bind-lexical (bind-arg-lexical? arg))
- (new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
- (new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
- (case mode
- ((required) (iterate (cdr tail) mode
- (cons arg required) optional
- new-lexical new-dynamic))
- ((optional) (iterate (cdr tail) mode
- required (cons arg optional)
- new-lexical new-dynamic))
- (else
- (error "invalid mode in split-lambda-arguments"
- mode)))))))))
-
- ;;; Compile a lambda expression. One thing we have to be aware of is
- ;;; that lambda arguments are usually dynamically bound, even when a
- ;;; lexical binding is intact for a symbol. For symbols that are marked
- ;;; as 'always lexical,' however, we lexically bind here as well, and
- ;;; thus we get them out of the let-dynamic call and register a lexical
- ;;; binding for them (the lexical target variable is already there,
- ;;; namely the real lambda argument from TreeIL).
-
- (define (compile-lambda loc args body)
- (if (not (list? args))
- (report-error loc "expected list for argument-list" args))
- (if (null? body)
- (report-error loc "function body must not be empty"))
- (receive (required optional rest lexical dynamic)
- (split-lambda-arguments loc args)
- (define (process-args args)
- (define (find-pairs pairs filter)
- (lset-intersection (lambda (name+sym x)
- (eq? (car name+sym) x))
- pairs
- filter))
- (let* ((syms (map (lambda (x) (gensym)) args))
- (pairs (map cons args syms))
- (lexical-pairs (find-pairs pairs lexical))
- (dynamic-pairs (find-pairs pairs dynamic)))
- (values syms pairs lexical-pairs dynamic-pairs)))
- (let*-values (((required-syms
- required-pairs
- required-lex-pairs
- required-dyn-pairs)
- (process-args required))
- ((optional-syms
- optional-pairs
- optional-lex-pairs
- optional-dyn-pairs)
- (process-args optional))
- ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
- (process-args (if rest (list rest) '())))
- ((the-rest-sym) (if rest (car rest-syms) #f))
- ((all-syms) (append required-syms
- optional-syms
- rest-syms))
- ((all-lex-pairs) (append required-lex-pairs
- optional-lex-pairs
- rest-lex-pairs))
- ((all-dyn-pairs) (append required-dyn-pairs
- optional-dyn-pairs
- rest-dyn-pairs)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- value-slot))
- dynamic)
- (with-dynamic-bindings
- (fluid-ref bindings-data)
- dynamic
- (lambda ()
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda
- loc
- '()
- (make-lambda-case
- #f
- required
- optional
- rest
- #f
- (map (lambda (x) (nil-value loc)) optional)
- all-syms
- (let ((compiled-body
- (list->seq loc (map compile-expr body))))
- (make-seq
- loc
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
- (make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body))))
- #f)))))))))
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+ (define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+ (define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+ (define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+ (define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+ (define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+ (define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+ (define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+ ;;; Partition the argument list of a lambda expression into required,
+ ;;; optional and rest arguments.
+
+ (define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+ (define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+ (define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il (compile-expr `(progn ,@forms)))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
;;; Special operators
(defspecial progn (loc args)
- (list->seq loc (map compile-expr args)))
- (make-sequence loc
- (if (null? args)
- (list (nil-value loc))
- (map compile-expr args))))
++ (list->seq loc
++ (if (null? args)
++ (list (nil-value loc))
++ (map compile-expr args))))
+
+ (defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
(defspecial if (loc args)
(pmatch args
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc sym (compile-expr value))
- (make-const loc sym)))))))
+ (make-seq loc
- (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym))))))
++ (set-variable! loc sym (compile-expr value))
++ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence
+ (make-seq
loc
- (list
+ (make-conditional
+ loc
(make-conditional
loc
- (make-conditional
+ (call-primitive
loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
+ 'module-bound?
(call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym (compile-expr value)))
- (make-const loc sym)))))))
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
++ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
- (make-sequence
+ (make-seq
loc
- (set-variable!
- (list
- (set-function!
++ (set-function!
+ loc
+ name
- function-slot
- (make-primcall loc 'cons
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
++ (make-call
+ loc
- name
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc
- `((name . ,name))
- args
- body))))
- (make-const loc name)))))
++ (make-module-ref loc '(guile) 'cons #t)
++ (list (make-const loc 'macro)
++ (compile-lambda loc
++ `((name . ,name))
++ args
++ body))))
+ (make-const loc name))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-function! loc
- name
- (compile-lambda loc
- `((name . ,name))
- args
- body))
- (make-const loc name)))))))
+ (make-seq loc
- (set-variable! loc
++ (set-function! loc
+ name
- function-slot
+ (compile-lambda loc
++ `((name . ,name))
+ args
+ body))
+ (make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args
((,val)
(make-const loc val))))
- (make-application loc
- (compile-expr function)
- (map compile-expr arguments)))))
+ (defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
++ (make-call loc
++ (compile-expr function)
++ (map compile-expr arguments)))))
+
+ (defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
;;; Compile a compound expression to Tree-IL.
(define (compile-pair loc expr)
HCoop / bpt / guile.git / commitdiff