369.8
svn: r5594
This commit is contained in:
Matthew Flatt
parent
3f384b343c
commit
4b765cfa5a
|
|
@ -58,12 +58,13 @@
|
|||
|
||||
(provide* ctype-sizeof ctype-alignof compiler-sizeof
|
||||
malloc free end-stubborn-change
|
||||
cpointer? ptr-equal? (unsafe ptr-ref) (unsafe ptr-set!)
|
||||
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
|
||||
ctype? make-ctype make-cstruct-type make-sized-byte-string
|
||||
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
|
||||
_fixint _ufixint _fixnum _ufixnum
|
||||
_float _double _double*
|
||||
_bool _pointer _scheme _fpointer)
|
||||
_bool _pointer _scheme _fpointer
|
||||
(unsafe memcpy) (unsafe memmove) (unsafe memset))
|
||||
|
||||
(define-syntax define*
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -134,8 +134,8 @@
|
|||
#xFFF #x1FFF #x3FFF #x7FFF #xFFFF)])
|
||||
(lambda (a s)
|
||||
(let-values ([(hi lo s)
|
||||
(cond [(< 0 s 16) (values (car a) (cdr a) s)]
|
||||
[(< s 32) (values (cdr a) (car a) (- s 16))]
|
||||
(cond [(< s 16) (values (car a) (cdr a) s)]
|
||||
[(< s 32) (values (cdr a) (car a) (- s 16))]
|
||||
[else (error 'word<<< "shift out of range: ~e"
|
||||
s)])])
|
||||
(cons! a
|
||||
|
|
@ -161,12 +161,12 @@
|
|||
;; (error 'bytes->word-vector! "something bad happened"))
|
||||
(let loop ([n 15])
|
||||
(when (<= 0 n)
|
||||
(let ([m (* 4 n)])
|
||||
(let ([m (arithmetic-shift n 2)])
|
||||
(cons! (vector-ref result n)
|
||||
(+ (bytes-ref l-raw (+ 2 m))
|
||||
(* 256 (bytes-ref l-raw (+ 3 m))))
|
||||
(arithmetic-shift (bytes-ref l-raw (+ 3 m)) 8))
|
||||
(+ (bytes-ref l-raw m)
|
||||
(* 256 (bytes-ref l-raw (+ 1 m))))))
|
||||
(arithmetic-shift (bytes-ref l-raw (+ 1 m)) 8))))
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(define empty-port (open-input-bytes #""))
|
||||
|
|
|
|||
|
|
@ -55,3 +55,5 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); }
|
|||
/* typedef int2int(*int_to_int2int)(int); */
|
||||
/* int hoho(int x, int_to_int2int f) { */
|
||||
X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
|
||||
|
||||
X int grab7th(void *p) { return ((char *)p)[7]; }
|
||||
|
|
|
|||
|
|
@ -120,10 +120,56 @@
|
|||
(lambda (x y)
|
||||
(let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
|
||||
(cond [(< x y) -1] [(> x y) +1] [else 0])))))
|
||||
|
||||
;; ---
|
||||
(t 55 'grab7th (_fun _pointer -> _int ) #"012345678")
|
||||
(t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1))
|
||||
(t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3))
|
||||
)
|
||||
|
||||
(report-errs)
|
||||
;; Test pointer arithmetic and memmove-like operations
|
||||
(let ([p (malloc 10 _int)])
|
||||
(memset p 0 10 _int)
|
||||
(test 0 ptr-ref p _int)
|
||||
(test 0 ptr-ref (ptr-add p 3 _int) _int)
|
||||
(ptr-set! p _int 5)
|
||||
(test 5 ptr-ref p _int)
|
||||
(test 0 ptr-ref (ptr-add p 3 _int) _int)
|
||||
(memcpy p 3 _int p 0 1 _int)
|
||||
(test 5 ptr-ref (ptr-add p 3 _int) _int)
|
||||
|
||||
;; A MzScheme `int' is always 4 bytes.
|
||||
(memset p 1 _int 17 9 _int)
|
||||
(test 5 ptr-ref p _int)
|
||||
(test #x11111111 ptr-ref (ptr-add p 4) _int)
|
||||
(memset p 2 18 9 _int)
|
||||
(test #x12121212 ptr-ref (ptr-add p 4) _int)
|
||||
(if (system-big-endian?)
|
||||
(test #x00001212 ptr-ref p _int)
|
||||
(test #x12120005 ptr-ref p _int))
|
||||
|
||||
(ptr-set! (ptr-add p 4 _int) _int 10)
|
||||
(ptr-set! (ptr-add p 5 _int) _int 11)
|
||||
(ptr-set! (ptr-add p 6 _int) _int 12)
|
||||
(memmove p 2 _int p 4 _int 3 _int)
|
||||
(test 10 ptr-ref (ptr-add p 2 _int) _int)
|
||||
(test 11 ptr-ref (ptr-add p 3 _int) _int)
|
||||
(test 12 ptr-ref (ptr-add p 4 _int) _int)
|
||||
(memmove p 6 _short p 8 _byte 12)
|
||||
(test 10 ptr-ref (ptr-add p 2 _int) _int)
|
||||
(test 10 ptr-ref (ptr-add p 3 _int) _int)
|
||||
(test 11 ptr-ref (ptr-add p 4 _int) _int)
|
||||
(test 12 ptr-ref (ptr-add p 5 _int) _int)
|
||||
(test 12 ptr-ref (ptr-add p 6 _int) _int)
|
||||
(memmove p p 8 4)
|
||||
(test 10 ptr-ref p _int)
|
||||
|
||||
(test #f ptr-equal? p (ptr-add p 3))
|
||||
(test #t ptr-equal? p (ptr-add (ptr-add p 3) -3))
|
||||
(test #f ptr-equal? #f (ptr-add #f 8))
|
||||
(test #t ptr-equal? #f (ptr-add (ptr-add #f 8) -8)))
|
||||
|
||||
(report-errs)
|
||||
|
||||
#| --- ignore everything below ---
|
||||
|
||||
|
|
|
|||
|
|
@ -1662,6 +1662,21 @@
|
|||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Check that [\s] doesn't match \s, etc.
|
||||
(let ([test-both
|
||||
(lambda (r bstr arg)
|
||||
(test (and r (list r))regexp-match (byte-pregexp bstr) arg)
|
||||
(test (and r (list (bytes->string/latin-1 r)) )
|
||||
regexp-match
|
||||
(pregexp (bytes->string/latin-1 bstr))
|
||||
(bytes->string/latin-1 arg)))])
|
||||
(test-both #f #"[\\s]" #"a")
|
||||
(test-both #f #"[\\s]" #"s")
|
||||
(test-both #" " #"[\\s]" #" ")
|
||||
(test-both #"a" #"[^\\s]" #"a")
|
||||
(test-both #"s" #"[^\\s]" #"s")
|
||||
(test-both #f #"[^\\s]" #" "))
|
||||
|
||||
;; Check that rx doesn't parse as px:
|
||||
(test '(#"aa" #"a") regexp-match #px#"(a)\\1" #"aa")
|
||||
(test '(#"a1" #"a") regexp-match #rx#"(a)\\1" #"a1")
|
||||
|
|
|
|||
|
|
@ -73,12 +73,19 @@ Like `read', but for a stream that starts with WXME-format data. If
|
|||
multiple S-expressions are in the WXME data, they are all read and
|
||||
combined with `begin'.
|
||||
|
||||
If MrEd is available (as determined by checking for `#%mred-kernel'),
|
||||
then MrEd is used via `open-input-text-editor'. Otherwise,
|
||||
`wxme-port->port' is used.
|
||||
|
||||
> (wxme-read-syntax source-v port)
|
||||
|
||||
Like `read-syntax', but for a WXME format input stream. If multiple
|
||||
S-expressions are in the WXME data, they are all read and combined
|
||||
with `begin'.
|
||||
|
||||
If MrEd is available (as determined by checking for `#%mred-kernel'),
|
||||
then MrEd is used via `open-input-text-editor'. Otherwise,
|
||||
`wxme-port->port' is used.
|
||||
|
||||
> snip-reader<%>
|
||||
|
||||
|
|
|
|||
|
|
@ -616,7 +616,17 @@
|
|||
(wxme-convert-port port close? #f))
|
||||
|
||||
(define (do-read port who read)
|
||||
(let ([port (decode who port (lambda (x) x) #f)])
|
||||
(let ([port (if (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(dynamic-require '#%mred-kernel #f)
|
||||
#t)
|
||||
;; GUI mode, since MrEd is available:
|
||||
(let ([text% (dynamic-require '(lib "mred.ss" "mred") 'text%)]
|
||||
[open-input-text-editor (dynamic-require '(lib "mred.ss" "mred") 'open-input-text-editor)])
|
||||
(let ([t (new text%)])
|
||||
(send t insert-port port 'standard)
|
||||
(open-input-text-editor t 0 'end values (object-name port) #t)))
|
||||
;; Non-GUI mode:
|
||||
(decode who port (lambda (x) x) #f))])
|
||||
(let ([v (read port)])
|
||||
(let ([v2 (let loop ()
|
||||
(let ([v2 (read port)])
|
||||
|
|
|
|||
|
|
@ -1,5 +1,10 @@
|
|||
Version 369.8
|
||||
Added -p, -P, and -Q command-line options
|
||||
Changed H-expression parsing to represent angle brackets specially
|
||||
Added syntax-local-expand-expression
|
||||
MzLib: foreign.ss: Added ptr-add, memmove, memcpy, and memset
|
||||
Inside MzScheme: added scheme_set_type_equality(), based on a patch
|
||||
from Dimitris Vyzovitis
|
||||
|
||||
Version 369.7
|
||||
Added string->path-element and path-element->string
|
||||
|
|
|
|||
|
|
@ -74,6 +74,8 @@
|
|||
# define GC_CAN_IGNORE /* empty */
|
||||
#endif
|
||||
|
||||
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
|
||||
|
||||
/* same as the macro in file.c */
|
||||
#define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
|
||||
|
||||
|
|
@ -487,6 +489,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: -none-
|
||||
* Predicate: -none-
|
||||
* Scheme->C: -none-
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_void
|
||||
*/
|
||||
|
||||
|
|
@ -496,6 +499,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tsint8
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -505,6 +509,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tuint8
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -514,6 +519,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tsint16
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -523,6 +529,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tuint16
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -533,6 +540,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tsint32
|
||||
* Predicate: scheme_get_realint_val(<Scheme>,&aux)
|
||||
* Scheme->C: -none- (set by the predicate)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_realinteger_value(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -543,6 +551,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tuint32
|
||||
* Predicate: scheme_get_unsigned_realint_val(<Scheme>,&aux)
|
||||
* Scheme->C: -none- (set by the predicate)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_realinteger_value_from_unsigned(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -552,6 +561,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tsint64
|
||||
* Predicate: scheme_get_long_long_val(<Scheme>,&aux)
|
||||
* Scheme->C: -none- (set by the predicate)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_value_from_long_long(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -561,6 +571,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tuint64
|
||||
* Predicate: scheme_get_unsigned_long_long_val(<Scheme>,&aux)
|
||||
* Scheme->C: -none- (set by the predicate)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_value_from_unsigned_long_long(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -571,6 +582,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tsint32
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -581,6 +593,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Tuint32
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -600,6 +613,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: long
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_INT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -610,6 +624,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: unsigned long
|
||||
* Predicate: SCHEME_INTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_UINT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_integer_from_unsigned(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -619,6 +634,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: float
|
||||
* Predicate: SCHEME_FLTP(<Scheme>)
|
||||
* Scheme->C: SCHEME_FLT_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_float(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -628,6 +644,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: double
|
||||
* Predicate: SCHEME_DBLP(<Scheme>)
|
||||
* Scheme->C: SCHEME_DBL_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_double(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -638,6 +655,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: double
|
||||
* Predicate: SCHEME_REALP(<Scheme>)
|
||||
* Scheme->C: scheme_real_to_double(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_double(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -648,6 +666,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: int
|
||||
* Predicate: 1
|
||||
* Scheme->C: SCHEME_TRUEP(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: (<C>?scheme_true:scheme_false)
|
||||
*/
|
||||
|
||||
|
|
@ -661,6 +680,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: mzchar*
|
||||
* Predicate: SCHEME_CHAR_STRINGP(<Scheme>)
|
||||
* Scheme->C: SCHEME_CHAR_STR_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_char_string_without_copying(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -670,6 +690,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: unsigned short*
|
||||
* Predicate: SCHEME_CHAR_STRINGP(<Scheme>)
|
||||
* Scheme->C: ucs4_string_to_utf16_pointer(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -682,6 +703,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: char*
|
||||
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
|
||||
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -691,6 +713,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: char*
|
||||
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
|
||||
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
|
||||
* S->C offset: 0
|
||||
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -700,6 +723,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: char*
|
||||
* Predicate: SCHEME_SYMBOLP(<Scheme>)
|
||||
* Scheme->C: SCHEME_SYM_VAL(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_intern_symbol(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -712,6 +736,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: void*
|
||||
* Predicate: SCHEME_FFIANYPTRP(<Scheme>)
|
||||
* Scheme->C: SCHEME_FFIANYPTR_VAL(<Scheme>)
|
||||
* S->C offset: FFIANYPTR
|
||||
* C->Scheme: scheme_make_foreign_cpointer(<C>)
|
||||
*/
|
||||
|
||||
|
|
@ -723,6 +748,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: Scheme_Object*
|
||||
* Predicate: 1
|
||||
* Scheme->C: <Scheme>
|
||||
* S->C offset: 0
|
||||
* C->Scheme: <C>
|
||||
*/
|
||||
|
||||
|
|
@ -735,6 +761,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C type: -none-
|
||||
* Predicate: -none-
|
||||
* Scheme->C: -none-
|
||||
* S->C offset: 0
|
||||
* C->Scheme: -none-
|
||||
*/
|
||||
|
||||
|
|
@ -990,6 +1017,10 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
|
|||
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
|
||||
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
|
||||
NULL)))
|
||||
#define SCHEME_FFIANYPTR_OFFSET(x) \
|
||||
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
|
||||
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
|
||||
W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
|
||||
|
||||
#define scheme_make_foreign_cpointer(x) \
|
||||
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
|
||||
|
|
@ -1078,7 +1109,6 @@ END_XFORM_SKIP;
|
|||
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
|
||||
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
|
||||
#endif
|
||||
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
|
||||
|
||||
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
|
||||
{
|
||||
|
|
@ -1135,9 +1165,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
|
|||
* the function is different: in the relevant cases zero an int and offset the
|
||||
* ptr */
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
|
||||
#else
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,_offset,basep)
|
||||
#endif
|
||||
|
||||
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
|
||||
|
|
@ -1145,7 +1175,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
|
|||
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
|
||||
* then a struct value will be *copied* into dst. */
|
||||
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
||||
Scheme_Object *val, long *basetype_p,
|
||||
Scheme_Object *val, long *basetype_p, long *_offset,
|
||||
int ret_loc)
|
||||
{
|
||||
if (!SCHEME_CTYPEP(type))
|
||||
|
|
@ -1178,7 +1208,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tsint8 tmp;
|
||||
tmp = (Tsint8)(SCHEME_INT_VAL(val));
|
||||
(((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","int8",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1193,7 +1222,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tuint8 tmp;
|
||||
tmp = (Tuint8)(SCHEME_UINT_VAL(val));
|
||||
(((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1208,7 +1236,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tsint16 tmp;
|
||||
tmp = (Tsint16)(SCHEME_INT_VAL(val));
|
||||
(((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","int16",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1223,7 +1250,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tuint16 tmp;
|
||||
tmp = (Tuint16)(SCHEME_UINT_VAL(val));
|
||||
(((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1250,7 +1276,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tsint32 tmp;
|
||||
tmp = (Tsint32)(SCHEME_INT_VAL(val));
|
||||
(((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1265,7 +1290,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
Tuint32 tmp;
|
||||
tmp = (Tuint32)(SCHEME_UINT_VAL(val));
|
||||
(((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1280,7 +1304,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
long tmp;
|
||||
tmp = (long)(SCHEME_INT_VAL(val));
|
||||
(((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1295,7 +1318,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_INTP(val)) {
|
||||
unsigned long tmp;
|
||||
tmp = (unsigned long)(SCHEME_UINT_VAL(val));
|
||||
(((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1310,7 +1332,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_FLTP(val)) {
|
||||
float tmp;
|
||||
tmp = (float)(SCHEME_FLT_VAL(val));
|
||||
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","float",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1325,7 +1346,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_DBLP(val)) {
|
||||
double tmp;
|
||||
tmp = (double)(SCHEME_DBL_VAL(val));
|
||||
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","double",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1340,7 +1360,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_REALP(val)) {
|
||||
double tmp;
|
||||
tmp = (double)(scheme_real_to_double(val));
|
||||
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","double*",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1355,7 +1374,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (1) {
|
||||
int tmp;
|
||||
tmp = (int)(SCHEME_TRUEP(val));
|
||||
(((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","bool",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1370,11 +1388,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_CHAR_STRINGP(val)) {
|
||||
mzchar* tmp;
|
||||
tmp = (mzchar*)(SCHEME_CHAR_STR_VAL(val));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_string_ucs_4; return tmp;
|
||||
*basetype_p = FOREIGN_string_ucs_4;
|
||||
return tmp;
|
||||
}
|
||||
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1389,11 +1410,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_CHAR_STRINGP(val)) {
|
||||
unsigned short* tmp;
|
||||
tmp = (unsigned short*)(ucs4_string_to_utf16_pointer(val));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_string_utf_16; return tmp;
|
||||
*basetype_p = FOREIGN_string_utf_16;
|
||||
return tmp;
|
||||
}
|
||||
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1408,11 +1432,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
|
||||
char* tmp;
|
||||
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_bytes; return tmp;
|
||||
*basetype_p = FOREIGN_bytes;
|
||||
return tmp;
|
||||
}
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","bytes",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1427,11 +1454,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
|
||||
char* tmp;
|
||||
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_path; return tmp;
|
||||
*basetype_p = FOREIGN_path;
|
||||
return tmp;
|
||||
}
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","path",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1446,11 +1476,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (SCHEME_SYMBOLP(val)) {
|
||||
char* tmp;
|
||||
tmp = (char*)(SCHEME_SYM_VAL(val));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_symbol; return tmp;
|
||||
*basetype_p = FOREIGN_symbol;
|
||||
return tmp;
|
||||
}
|
||||
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","symbol",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1463,13 +1496,18 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
}
|
||||
#endif
|
||||
if (SCHEME_FFIANYPTRP(val)) {
|
||||
void* tmp;
|
||||
void* tmp; long toff;
|
||||
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
toff = SCHEME_FFIANYPTR_OFFSET(val);
|
||||
if (_offset) *_offset = toff;
|
||||
if (basetype_p == NULL ||(tmp == NULL && toff == 0)) {
|
||||
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_pointer; return tmp;
|
||||
*basetype_p = FOREIGN_pointer;
|
||||
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
|
||||
}
|
||||
(((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1484,11 +1522,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (1) {
|
||||
Scheme_Object* tmp;
|
||||
tmp = (Scheme_Object*)(val);
|
||||
if (basetype_p == NULL || tmp == NULL) {
|
||||
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_scheme; return tmp;
|
||||
*basetype_p = FOREIGN_scheme;
|
||||
return tmp;
|
||||
}
|
||||
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
|
||||
return NULL; /* shush the compiler */
|
||||
|
|
@ -1498,14 +1539,22 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
case FOREIGN_struct:
|
||||
if (!SCHEME_FFIANYPTRP(val))
|
||||
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
|
||||
if (basetype_p == NULL) {
|
||||
{
|
||||
void* p = SCHEME_FFIANYPTR_VAL(val);
|
||||
if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
|
||||
memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
return SCHEME_FFIANYPTR_VAL(val);
|
||||
long poff = SCHEME_FFIANYPTR_OFFSET(val);
|
||||
if (basetype_p == NULL) {
|
||||
if (p == NULL && poff == 0) scheme_signal_error("FFI pointer value was NULL.");
|
||||
memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff), CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
if (_offset) {
|
||||
*_offset = poff;
|
||||
return p;
|
||||
} else {
|
||||
return W_OFFSET(p, poff);
|
||||
}
|
||||
}
|
||||
}
|
||||
default: scheme_signal_error("corrupt foreign type: %V", type);
|
||||
}
|
||||
|
|
@ -1643,6 +1692,8 @@ static Scheme_Object *atomic_sym;
|
|||
static Scheme_Object *stubborn_sym;
|
||||
static Scheme_Object *uncollectable_sym;
|
||||
static Scheme_Object *eternal_sym;
|
||||
static Scheme_Object *interior_sym;
|
||||
static Scheme_Object *atomic_interior_sym;
|
||||
static Scheme_Object *raw_sym;
|
||||
static Scheme_Object *fail_ok_sym;
|
||||
|
||||
|
|
@ -1666,6 +1717,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
|
|||
{
|
||||
int i, size=0, num=0, failok=0;
|
||||
void *from = NULL, *res = NULL;
|
||||
long foff = 0;
|
||||
Scheme_Object *mode = NULL, *a, *base = NULL;
|
||||
void *(*mf)(size_t);
|
||||
for (i=0; i<argc; i++) {
|
||||
|
|
@ -1695,6 +1747,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
|
|||
scheme_signal_error(MYNAME": specifying a second source pointer: %V",
|
||||
a);
|
||||
from = SCHEME_FFIANYPTR_VAL(a);
|
||||
foff = SCHEME_FFIANYPTR_OFFSET(a);
|
||||
} else {
|
||||
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
|
||||
}
|
||||
|
|
@ -1709,13 +1762,15 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
|
|||
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
|
||||
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
|
||||
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
|
||||
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
||||
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
||||
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
|
||||
else {
|
||||
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
|
||||
return NULL; /* shush the compiler */
|
||||
}
|
||||
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
|
||||
if ((from != NULL) && (res != NULL)) memcpy(res, from, size);
|
||||
if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size);
|
||||
return scheme_make_foreign_cpointer(res);
|
||||
}
|
||||
|
||||
|
|
@ -1725,12 +1780,14 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
|
|||
static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
void *ptr;
|
||||
long poff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (poff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
scheme_end_stubborn_change(ptr);
|
||||
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
|
|
@ -1742,15 +1799,165 @@ static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[
|
|||
static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
void *ptr;
|
||||
long poff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (poff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
free(ptr);
|
||||
free(W_OFFSET(ptr, poff));
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
#define C_LONG_TYPE_STR "exact integer that fits a C long"
|
||||
|
||||
#undef MYNAME
|
||||
#define MYNAME "ptr-add"
|
||||
static Scheme_Object *foreign_ptr_add(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
void *ptr;
|
||||
long poff, noff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if (!scheme_get_int_val(argv[1], &noff)) {
|
||||
scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
|
||||
}
|
||||
if (argc > 2) {
|
||||
if (SCHEME_CTYPEP(argv[2])) {
|
||||
long size;
|
||||
if (NULL == get_ctype_base(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
size = ctype_sizeof(argv[2]);
|
||||
if (size <= 0)
|
||||
scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
|
||||
|
||||
noff = noff * size;
|
||||
} else
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
}
|
||||
return scheme_make_offset_cptr(ptr, poff + noff, NULL);
|
||||
}
|
||||
|
||||
/* (mem{move,copy} dest-ptr [dest-offset [dest-offset-type]]
|
||||
src-ptr [src-offset [src-c-offset-type]]
|
||||
cnt [c-type]) */
|
||||
/* Copies cnt*sizeof(c-type) bytes from src-ptr + src-offset * sizeof(dest-offset-c-type)
|
||||
to dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
|
||||
/* or (memset dest-ptr [dest-offset [dest-offset-type]] byte cnt [c-type]) */
|
||||
/* Sets cnt*sizeof(c-type) bytes to byte
|
||||
at dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
|
||||
/* The argument handling for the function is very similar, so we just package it all
|
||||
together. */
|
||||
static Scheme_Object *do_memop(const char *who, int is_copy, int argc, Scheme_Object **argv)
|
||||
{
|
||||
void *src = NULL, *dest = NULL;
|
||||
long soff = 0, doff = 0, cnt = 0;
|
||||
int j, i = argc - 1, ch = 0;
|
||||
|
||||
for (j = 3; j--; ) {
|
||||
if (!is_copy && (j == 1)) {
|
||||
/* Just get byte */
|
||||
if (i < 0)
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: missing the fill-byte argument (parsing from right to left)",
|
||||
who);
|
||||
ch = SCHEME_INTP(argv[i]) ? SCHEME_INT_VAL(argv[i]) : -1;
|
||||
if ((ch < 0) || (ch > 255))
|
||||
scheme_wrong_type(who, "byte", i, argc, argv);
|
||||
i--;
|
||||
} else {
|
||||
long size, v = 0;
|
||||
if (SCHEME_CTYPEP(argv[i])) {
|
||||
if (NULL == get_ctype_base(argv[i]))
|
||||
scheme_wrong_type(who, "C-type", i, argc, argv);
|
||||
size = ctype_sizeof(argv[i]);
|
||||
if (size <= 0)
|
||||
scheme_wrong_type(who, "non-void-C-type", i, argc, argv);
|
||||
--i;
|
||||
} else
|
||||
size = 0;
|
||||
if (SCHEME_EXACT_INTEGERP(argv[i])) {
|
||||
if (!scheme_get_int_val(argv[i], &v)) {
|
||||
scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
|
||||
}
|
||||
--i;
|
||||
} else if (size || (j == 2)) {
|
||||
/* must have final count: */
|
||||
scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, i, argc, argv);
|
||||
}
|
||||
|
||||
if (size)
|
||||
v = v * size;
|
||||
|
||||
switch (j) {
|
||||
case 0:
|
||||
doff = v;
|
||||
break;
|
||||
case 1:
|
||||
soff = v;
|
||||
break;
|
||||
case 2:
|
||||
cnt = v;
|
||||
}
|
||||
|
||||
if (j < 2) {
|
||||
if (i < 0) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: missing a pointer argument for %s (parsing from right to left)",
|
||||
who,
|
||||
(j == 0 ? "destination" : "source"));
|
||||
}
|
||||
|
||||
if (!SCHEME_FFIANYPTRP(argv[i]))
|
||||
scheme_wrong_type(who, "cpointer", i, argc, argv);
|
||||
if (j == 0) {
|
||||
dest = SCHEME_FFIANYPTR_VAL(argv[i]);
|
||||
doff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
||||
} else {
|
||||
src = SCHEME_FFIANYPTR_VAL(argv[i]);
|
||||
soff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
||||
}
|
||||
--i;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (i >= 0) {
|
||||
scheme_arg_mismatch(who, "unexpected extra argument (parsing from right to left): ", argv[i]);
|
||||
}
|
||||
|
||||
if (is_copy)
|
||||
memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), cnt);
|
||||
else
|
||||
memset(W_OFFSET(dest, doff), ch, cnt);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
#undef MYNAME
|
||||
#define MYNAME "memmove"
|
||||
static Scheme_Object *foreign_memmove(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_memop(MYNAME, 1, argc, argv);
|
||||
}
|
||||
|
||||
#undef MYNAME
|
||||
#define MYNAME "memcpy"
|
||||
static Scheme_Object *foreign_memcpy(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_memop(MYNAME, 1, argc, argv);
|
||||
}
|
||||
|
||||
#undef MYNAME
|
||||
#define MYNAME "memset"
|
||||
static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_memop(MYNAME, 0, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *abs_sym;
|
||||
|
||||
/* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
|
||||
|
|
@ -1763,12 +1970,13 @@ static Scheme_Object *abs_sym;
|
|||
static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
int size=0; void *ptr; Scheme_Object *base;
|
||||
long delta = 0;
|
||||
long delta;
|
||||
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (delta == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(argv[1])))
|
||||
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
||||
|
|
@ -1789,11 +1997,11 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
|
||||
if (!SCHEME_INTP(argv[3]))
|
||||
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
||||
delta = SCHEME_INT_VAL(argv[3]);
|
||||
delta += SCHEME_INT_VAL(argv[3]);
|
||||
} else if (argc > 2) {
|
||||
if (!SCHEME_INTP(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
||||
delta = (size * SCHEME_INT_VAL(argv[2]));
|
||||
delta += (size * SCHEME_INT_VAL(argv[2]));
|
||||
}
|
||||
return C2SCHEME(argv[1], ptr, delta, 0);
|
||||
}
|
||||
|
|
@ -1808,12 +2016,13 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
|
|||
static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
int size=0; void *ptr;
|
||||
long delta = 0;
|
||||
long delta;
|
||||
Scheme_Object *val = argv[argc-1], *base;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (delta == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(argv[1])))
|
||||
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
||||
|
|
@ -1840,13 +2049,13 @@ static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
|
|||
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
|
||||
if (!SCHEME_INTP(argv[3]))
|
||||
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
||||
delta = SCHEME_INT_VAL(argv[3]);
|
||||
delta += SCHEME_INT_VAL(argv[3]);
|
||||
} else if (argc > 3) {
|
||||
if (!SCHEME_INTP(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
||||
delta = (size * SCHEME_INT_VAL(argv[2]));
|
||||
delta += (size * SCHEME_INT_VAL(argv[2]));
|
||||
}
|
||||
SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
|
||||
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
|
|
@ -1860,7 +2069,7 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_FFIANYPTRP(argv[1]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
|
||||
return (SAME_OBJ(argv[0],argv[1]) ||
|
||||
(SCHEME_FFIANYPTR_VAL(argv[0]) == SCHEME_FFIANYPTR_VAL(argv[1])))
|
||||
((SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) == SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))))
|
||||
? scheme_true : scheme_false;
|
||||
}
|
||||
|
||||
|
|
@ -1869,6 +2078,7 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
|
|||
#define MYNAME "make-sized-byte-string"
|
||||
static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[])
|
||||
/* Warning: no copying is done so it is possible to share string contents. */
|
||||
/* Warning: if source ptr has a offset, resulting string object uses shifted pointer. */
|
||||
/* (Should use real byte-strings with new version.) */
|
||||
{
|
||||
long len;
|
||||
|
|
@ -1878,7 +2088,7 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar
|
|||
scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
|
||||
if (SCHEME_FALSEP(argv[0])) return scheme_false;
|
||||
else return
|
||||
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_VAL(argv[0]), len, 0);
|
||||
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), len, 0);
|
||||
}
|
||||
|
||||
/* internal: apply Scheme finalizer */
|
||||
|
|
@ -1950,6 +2160,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
Scheme_Object *otype = SCHEME_VEC_ELS(data)[3];
|
||||
Scheme_Object *base;
|
||||
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
|
||||
long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
|
||||
int nargs = cif->nargs;
|
||||
/* When the foreign function is called, we need an array (ivals) of nargs
|
||||
* ForeignAny objects to store the actual C values that are created, and we
|
||||
|
|
@ -1970,25 +2181,30 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
void **avalues, *p, *newp, *tmp;
|
||||
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
|
||||
void *stack_avalues[MAX_QUICK_ARGS];
|
||||
long stack_offsets[MAX_QUICK_ARGS];
|
||||
int i;
|
||||
long basetype;
|
||||
long basetype, offset, *offsets;
|
||||
if (nargs <= MAX_QUICK_ARGS) {
|
||||
ivals = stack_ivals;
|
||||
avalues = stack_avalues;
|
||||
offsets = stack_offsets;
|
||||
} else {
|
||||
ivals = malloc(nargs * sizeof(ForeignAny));
|
||||
avalues = scheme_malloc(nargs * sizeof(void*));
|
||||
offsets = scheme_malloc(nargs * sizeof(long));
|
||||
}
|
||||
/* iterate on input values and types */
|
||||
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
|
||||
/* convert argv[i] according to current itype */
|
||||
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
|
||||
offset = 0;
|
||||
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0);
|
||||
if (p != NULL) {
|
||||
avalues[i] = p;
|
||||
ivals[i].x_fixnum = basetype; /* remember the base type */
|
||||
} else {
|
||||
avalues[i] = NULL;
|
||||
}
|
||||
offsets[i] = offset;
|
||||
}
|
||||
base = get_ctype_base(otype); /* verified below, so cannot be NULL */
|
||||
/* If this is a struct return value, then need to malloc in any case, even if
|
||||
|
|
@ -2002,7 +2218,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
p = &oval;
|
||||
newp = NULL;
|
||||
}
|
||||
/* We finished with all possible mallocs, clear up the avalues mess */
|
||||
/* We finished with all possible mallocs, clear up the avalues an offsets mess */
|
||||
for (i=0; i<nargs; i++) {
|
||||
if (avalues[i] == NULL) /* if this was a non-pointer... */
|
||||
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
|
||||
|
|
@ -2011,10 +2227,14 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
ivals[i].x_pointer = avalues[i];
|
||||
avalues[i] = &(ivals[i]);
|
||||
}
|
||||
/* Otherwise it was a struct pointer, and avalues[i] is already fine */
|
||||
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */
|
||||
/* Add offset, if any: */
|
||||
if (offsets[i] != 0) {
|
||||
ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
|
||||
}
|
||||
}
|
||||
/* Finally, call the function */
|
||||
ffi_call(cif, c_func, p, avalues);
|
||||
ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
|
||||
if (ivals != stack_ivals) free(ivals);
|
||||
ivals = NULL; /* no need now to hold on to this */
|
||||
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
|
||||
|
|
@ -2056,6 +2276,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
Scheme_Object *itypes = argv[1];
|
||||
Scheme_Object *otype = argv[2];
|
||||
Scheme_Object *obj, *data, *p, *base;
|
||||
long ooff;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs;
|
||||
|
|
@ -2065,7 +2286,8 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
|
||||
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (obj == NULL)
|
||||
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((obj == NULL) && (ooff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
nargs = scheme_proper_list_length(itypes);
|
||||
if (nargs < 0)
|
||||
|
|
@ -2084,7 +2306,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
|
||||
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
||||
data = scheme_make_vector(5, NULL);
|
||||
data = scheme_make_vector(6, NULL);
|
||||
p = scheme_append_byte_string
|
||||
(ffi_name_prefix,
|
||||
scheme_make_byte_string_without_copying
|
||||
|
|
@ -2095,6 +2317,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
|
|||
SCHEME_VEC_ELS(data)[2] = itypes;
|
||||
SCHEME_VEC_ELS(data)[3] = otype;
|
||||
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
|
||||
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
|
||||
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
|
||||
return scheme_make_closed_prim_w_arity
|
||||
(ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
|
||||
|
|
@ -2129,7 +2352,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
argv[i] = v;
|
||||
}
|
||||
p = _scheme_apply(data->proc, argc, argv);
|
||||
SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
|
||||
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
|
||||
}
|
||||
|
||||
/* see ffi-callback below */
|
||||
|
|
@ -2278,6 +2501,10 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
uncollectable_sym = scheme_intern_symbol("uncollectable");
|
||||
MZ_REGISTER_STATIC(eternal_sym);
|
||||
eternal_sym = scheme_intern_symbol("eternal");
|
||||
MZ_REGISTER_STATIC(interior_sym);
|
||||
interior_sym = scheme_intern_symbol("interior");
|
||||
MZ_REGISTER_STATIC(atomic_interior_sym);
|
||||
atomic_interior_sym = scheme_intern_symbol("atomic-interior");
|
||||
MZ_REGISTER_STATIC(raw_sym);
|
||||
raw_sym = scheme_intern_symbol("raw");
|
||||
MZ_REGISTER_STATIC(fail_ok_sym);
|
||||
|
|
@ -2330,6 +2557,14 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
|
||||
scheme_add_global("free",
|
||||
scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
|
||||
scheme_add_global("ptr-add",
|
||||
scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
|
||||
scheme_add_global("memmove",
|
||||
scheme_make_prim_w_arity(foreign_memmove, "memmove", 3, 8), menv);
|
||||
scheme_add_global("memcpy",
|
||||
scheme_make_prim_w_arity(foreign_memcpy, "memcpy", 3, 8), menv);
|
||||
scheme_add_global("memset",
|
||||
scheme_make_prim_w_arity(foreign_memset, "memset", 3, 6), menv);
|
||||
scheme_add_global("ptr-ref",
|
||||
scheme_make_prim_w_arity(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
|
||||
scheme_add_global("ptr-set!",
|
||||
|
|
|
|||
|
|
@ -81,6 +81,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
|
|||
# define GC_CAN_IGNORE /* empty */
|
||||
#endif
|
||||
|
||||
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
|
||||
|
||||
/* same as the macro in file.c */
|
||||
#define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
|
||||
|
||||
|
|
@ -423,6 +425,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
;; function with the same arguments as above)
|
||||
;; c->s: name of value construction macro/function
|
||||
;; (or a function of the value that generates the expression)
|
||||
;; offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset
|
||||
;; value for s->c, otherwise leave 0 as the offset
|
||||
|
||||
(define types '())
|
||||
|
||||
|
|
@ -431,7 +435,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
|
||||
(define *type-counter* 0)
|
||||
|
||||
(define (describe-type stype cname ftype ctype pred s->c c->s)
|
||||
(define (describe-type stype cname ftype ctype pred s->c c->s offset)
|
||||
(set! *type-counter* (add1 *type-counter*))
|
||||
(~ "#define FOREIGN_"cname" ("*type-counter*")" \\
|
||||
"/* Type Name: "stype (and (not (equal? cname stype))
|
||||
|
|
@ -446,6 +450,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
(if pred "-none- (set by the predicate)" "-none-")]
|
||||
[(procedure? s->c) (s->c "<Scheme>" "aux")]
|
||||
[else (list s->c"(<Scheme>)")]) \\
|
||||
" * S->C offset: "(cond
|
||||
[(not offset) "0"]
|
||||
[else offset]) \\
|
||||
" * C->Scheme: "(cond [(not c->s) "-none-"]
|
||||
[(procedure? c->s) (c->s "<C>")]
|
||||
[else (list c->s"(<C>)")]) \\
|
||||
|
|
@ -472,10 +479,11 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
[macro (prop 'macro)]
|
||||
[pred (prop 'pred (and macro (list "SCHEME_"macro"P")))]
|
||||
[s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
|
||||
[c->s (prop 'c->s)])
|
||||
(describe-type stype cname ftype ctype pred s->c c->s)
|
||||
[c->s (prop 'c->s)]
|
||||
[offset (prop 'offset #f)])
|
||||
(describe-type stype cname ftype ctype pred s->c c->s offset)
|
||||
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
|
||||
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s))))
|
||||
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
|
||||
|
||||
(define (defctype name . args)
|
||||
(set! types (append! types (list (make-ctype name args)))))
|
||||
|
|
@ -492,6 +500,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
[pred (id 'pred)]
|
||||
[s->c (id 's->c)]
|
||||
[c->s (id 'c->s)]
|
||||
[offset (id 'offset)]
|
||||
[ptr? (id 'ptr?)])
|
||||
#'(for-each
|
||||
(lambda (t)
|
||||
|
|
@ -505,6 +514,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
[pred (get 'pred)]
|
||||
[s->c (get 's->c)]
|
||||
[c->s (get 'c->s)]
|
||||
[offset (get 'offset)]
|
||||
[ptr? (equal? "pointer" ftype)])
|
||||
body ...))
|
||||
types)))]))
|
||||
|
|
@ -665,6 +675,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
(defctype 'pointer
|
||||
'ctype "void*"
|
||||
'macro "FFIANYPTR"
|
||||
'offset "FFIANYPTR"
|
||||
'c->s "scheme_make_foreign_cpointer")
|
||||
|
||||
;; This is probably not needed
|
||||
|
|
@ -856,6 +867,10 @@ void free_libffi_type(void *ignored, void *p)
|
|||
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
|
||||
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
|
||||
NULL)))
|
||||
#define SCHEME_FFIANYPTR_OFFSET(x) \
|
||||
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
|
||||
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
|
||||
W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
|
||||
|
||||
#define scheme_make_foreign_cpointer(x) \
|
||||
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
|
||||
|
|
@ -906,7 +921,6 @@ void free_libffi_type(void *ignored, void *p)
|
|||
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
|
||||
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
|
||||
#endif
|
||||
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
|
||||
|
||||
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
|
||||
{
|
||||
|
|
@ -944,9 +958,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
|
|||
* the function is different: in the relevant cases zero an int and offset the
|
||||
* ptr */
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
|
||||
#else
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
|
||||
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,_offset,basep)
|
||||
#endif
|
||||
|
||||
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
|
||||
|
|
@ -954,7 +968,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
|
|||
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
|
||||
* then a struct value will be *copied* into dst. */
|
||||
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
||||
Scheme_Object *val, long *basetype_p,
|
||||
Scheme_Object *val, long *basetype_p, long *_offset,
|
||||
int ret_loc)
|
||||
{
|
||||
if (!SCHEME_CTYPEP(type))
|
||||
|
|
@ -993,14 +1007,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
" }")
|
||||
(display "#endif\n")
|
||||
(~ " if ("(f pred)") {" \\
|
||||
" "ctype" tmp;" \\
|
||||
" "ctype" tmp;" (if offset " long toff;" "") \\
|
||||
" tmp = ("ctype")("(f s->c)");")
|
||||
(if ptr?
|
||||
(~ " if (basetype_p == NULL || tmp == NULL) {" \\
|
||||
" "x" = tmp; return NULL;" \\
|
||||
(when offset
|
||||
(~ " toff = SCHEME_"offset"_OFFSET(val);")
|
||||
(~ " if (_offset) *_offset = toff;"))
|
||||
(when ptr?
|
||||
(~ " if (basetype_p == NULL ||"
|
||||
(if offset
|
||||
"(tmp == NULL && toff == 0)"
|
||||
"tmp == NULL")
|
||||
") {")
|
||||
(if offset
|
||||
(~ " "x" = (_offset ? tmp : ("ctype")W_OFFSET(tmp, toff));")
|
||||
(~ " "x" = tmp;"))
|
||||
(~ " return NULL;" \\
|
||||
" } else {" \\
|
||||
" *basetype_p = FOREIGN_"cname"; return tmp;" \\
|
||||
" }")
|
||||
" *basetype_p = FOREIGN_"cname";")
|
||||
(if offset
|
||||
(~ " return _offset ? tmp : ("ctype")W_OFFSET(tmp, toff);")
|
||||
(~ " return tmp;"))
|
||||
(~ " }")
|
||||
(~ " "x" = tmp; return NULL;"))
|
||||
(~ " } else {" \\
|
||||
" "(wrong-type "val" stype) \\
|
||||
|
|
@ -1014,14 +1041,22 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
case FOREIGN_struct:
|
||||
if (!SCHEME_FFIANYPTRP(val))
|
||||
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
|
||||
if (basetype_p == NULL) {
|
||||
{
|
||||
void* p = SCHEME_FFIANYPTR_VAL(val);
|
||||
if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
|
||||
memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
return SCHEME_FFIANYPTR_VAL(val);
|
||||
long poff = SCHEME_FFIANYPTR_OFFSET(val);
|
||||
if (basetype_p == NULL) {
|
||||
if (p == NULL && poff == 0) scheme_signal_error("FFI pointer value was NULL.");
|
||||
memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff), CTYPE_PRIMTYPE(type)->size);
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_struct;
|
||||
if (_offset) {
|
||||
*_offset = poff;
|
||||
return p;
|
||||
} else {
|
||||
return W_OFFSET(p, poff);
|
||||
}
|
||||
}
|
||||
}
|
||||
default: scheme_signal_error("corrupt foreign type: %V", type);
|
||||
}
|
||||
|
|
@ -1148,7 +1183,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
/*****************************************************************************/
|
||||
/* Pointer type user functions */
|
||||
|
||||
{:(defsymbols nonatomic atomic stubborn uncollectable eternal raw fail-ok):}
|
||||
{:(defsymbols nonatomic atomic stubborn uncollectable eternal interior atomic-interior raw fail-ok):}
|
||||
|
||||
/* (malloc num type cpointer mode) -> pointer */
|
||||
/* The arguments for this function are:
|
||||
|
|
@ -1168,6 +1203,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
{
|
||||
int i, size=0, num=0, failok=0;
|
||||
void *from = NULL, *res = NULL;
|
||||
long foff = 0;
|
||||
Scheme_Object *mode = NULL, *a, *base = NULL;
|
||||
void *(*mf)(size_t);
|
||||
for (i=0; i<argc; i++) {
|
||||
|
|
@ -1197,6 +1233,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_signal_error(MYNAME": specifying a second source pointer: %V",
|
||||
a);
|
||||
from = SCHEME_FFIANYPTR_VAL(a);
|
||||
foff = SCHEME_FFIANYPTR_OFFSET(a);
|
||||
} else {
|
||||
scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
|
||||
}
|
||||
|
|
@ -1211,13 +1248,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
else if (SAME_OBJ(mode, stubborn_sym)) mf = scheme_malloc_stubborn;
|
||||
else if (SAME_OBJ(mode, eternal_sym)) mf = scheme_malloc_eternal;
|
||||
else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
|
||||
else if (SAME_OBJ(mode, interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
||||
else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
|
||||
else if (SAME_OBJ(mode, raw_sym)) mf = malloc;
|
||||
else {
|
||||
scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
|
||||
return NULL; /* shush the compiler */
|
||||
}
|
||||
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
|
||||
if ((from != NULL) && (res != NULL)) memcpy(res, from, size);
|
||||
if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size);
|
||||
return scheme_make_foreign_cpointer(res);
|
||||
}
|
||||
|
||||
|
|
@ -1225,12 +1264,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
{:(cdefine end-stubborn-change 1):}
|
||||
{
|
||||
void *ptr;
|
||||
long poff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (poff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
scheme_end_stubborn_change(ptr);
|
||||
scheme_end_stubborn_change(W_OFFSET(ptr, poff));
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
|
|
@ -1240,15 +1281,157 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
{:(cdefine free 1):}
|
||||
{
|
||||
void *ptr;
|
||||
long poff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (poff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
free(ptr);
|
||||
free(W_OFFSET(ptr, poff));
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
#define C_LONG_TYPE_STR "exact integer that fits a C long"
|
||||
|
||||
{:(cdefine ptr-add 2 3):}
|
||||
{
|
||||
void *ptr;
|
||||
long poff, noff;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if (!scheme_get_int_val(argv[1], &noff)) {
|
||||
scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
|
||||
}
|
||||
if (argc > 2) {
|
||||
if (SCHEME_CTYPEP(argv[2])) {
|
||||
long size;
|
||||
if (NULL == get_ctype_base(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
size = ctype_sizeof(argv[2]);
|
||||
if (size <= 0)
|
||||
scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
|
||||
|
||||
noff = noff * size;
|
||||
} else
|
||||
scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
|
||||
}
|
||||
return scheme_make_offset_cptr(ptr, poff + noff, NULL);
|
||||
}
|
||||
|
||||
/* (mem{move,copy} dest-ptr [dest-offset [dest-offset-type]]
|
||||
src-ptr [src-offset [src-c-offset-type]]
|
||||
cnt [c-type]) */
|
||||
/* Copies cnt*sizeof(c-type) bytes from src-ptr + src-offset * sizeof(dest-offset-c-type)
|
||||
to dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
|
||||
/* or (memset dest-ptr [dest-offset [dest-offset-type]] byte cnt [c-type]) */
|
||||
/* Sets cnt*sizeof(c-type) bytes to byte
|
||||
at dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
|
||||
/* The argument handling for the function is very similar, so we just package it all
|
||||
together. */
|
||||
static Scheme_Object *do_memop(const char *who, int is_copy, int argc, Scheme_Object **argv)
|
||||
{
|
||||
void *src = NULL, *dest = NULL;
|
||||
long soff = 0, doff = 0, cnt = 0;
|
||||
int j, i = argc - 1, ch = 0;
|
||||
|
||||
for (j = 3; j--; ) {
|
||||
if (!is_copy && (j == 1)) {
|
||||
/* Just get byte */
|
||||
if (i < 0)
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: missing the fill-byte argument (parsing from right to left)",
|
||||
who);
|
||||
ch = SCHEME_INTP(argv[i]) ? SCHEME_INT_VAL(argv[i]) : -1;
|
||||
if ((ch < 0) || (ch > 255))
|
||||
scheme_wrong_type(who, "byte", i, argc, argv);
|
||||
i--;
|
||||
} else {
|
||||
long size, v = 0;
|
||||
if (SCHEME_CTYPEP(argv[i])) {
|
||||
if (NULL == get_ctype_base(argv[i]))
|
||||
scheme_wrong_type(who, "C-type", i, argc, argv);
|
||||
size = ctype_sizeof(argv[i]);
|
||||
if (size <= 0)
|
||||
scheme_wrong_type(who, "non-void-C-type", i, argc, argv);
|
||||
--i;
|
||||
} else
|
||||
size = 0;
|
||||
if (SCHEME_EXACT_INTEGERP(argv[i])) {
|
||||
if (!scheme_get_int_val(argv[i], &v)) {
|
||||
scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
|
||||
}
|
||||
--i;
|
||||
} else if (size || (j == 2)) {
|
||||
/* must have final count: */
|
||||
scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, i, argc, argv);
|
||||
}
|
||||
|
||||
if (size)
|
||||
v = v * size;
|
||||
|
||||
switch (j) {
|
||||
case 0:
|
||||
doff = v;
|
||||
break;
|
||||
case 1:
|
||||
soff = v;
|
||||
break;
|
||||
case 2:
|
||||
cnt = v;
|
||||
}
|
||||
|
||||
if (j < 2) {
|
||||
if (i < 0) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: missing a pointer argument for %s (parsing from right to left)",
|
||||
who,
|
||||
(j == 0 ? "destination" : "source"));
|
||||
}
|
||||
|
||||
if (!SCHEME_FFIANYPTRP(argv[i]))
|
||||
scheme_wrong_type(who, "cpointer", i, argc, argv);
|
||||
if (j == 0) {
|
||||
dest = SCHEME_FFIANYPTR_VAL(argv[i]);
|
||||
doff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
||||
} else {
|
||||
src = SCHEME_FFIANYPTR_VAL(argv[i]);
|
||||
soff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
|
||||
}
|
||||
--i;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (i >= 0) {
|
||||
scheme_arg_mismatch(who, "unexpected extra argument (parsing from right to left): ", argv[i]);
|
||||
}
|
||||
|
||||
if (is_copy)
|
||||
memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), cnt);
|
||||
else
|
||||
memset(W_OFFSET(dest, doff), ch, cnt);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
{:(cdefine memmove 3 8):}
|
||||
{
|
||||
return do_memop(MYNAME, 1, argc, argv);
|
||||
}
|
||||
|
||||
{:(cdefine memcpy 3 8):}
|
||||
{
|
||||
return do_memop(MYNAME, 1, argc, argv);
|
||||
}
|
||||
|
||||
{:(cdefine memset 3 6):}
|
||||
{
|
||||
return do_memop(MYNAME, 0, argc, argv);
|
||||
}
|
||||
|
||||
{:(defsymbols abs):}
|
||||
|
||||
/* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
|
||||
|
|
@ -1259,12 +1442,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
{:(cdefine ptr-ref 2 4):}
|
||||
{
|
||||
int size=0; void *ptr; Scheme_Object *base;
|
||||
long delta = 0;
|
||||
long delta;
|
||||
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (delta == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(argv[1])))
|
||||
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
||||
|
|
@ -1285,11 +1469,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
|
||||
if (!SCHEME_INTP(argv[3]))
|
||||
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
||||
delta = SCHEME_INT_VAL(argv[3]);
|
||||
delta += SCHEME_INT_VAL(argv[3]);
|
||||
} else if (argc > 2) {
|
||||
if (!SCHEME_INTP(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
||||
delta = (size * SCHEME_INT_VAL(argv[2]));
|
||||
delta += (size * SCHEME_INT_VAL(argv[2]));
|
||||
}
|
||||
return C2SCHEME(argv[1], ptr, delta, 0);
|
||||
}
|
||||
|
|
@ -1302,12 +1486,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
{:(cdefine ptr-set! 3 5):}
|
||||
{
|
||||
int size=0; void *ptr;
|
||||
long delta = 0;
|
||||
long delta;
|
||||
Scheme_Object *val = argv[argc-1], *base;
|
||||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
|
||||
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (ptr == NULL)
|
||||
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((ptr == NULL) && (delta == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
if (NULL == (base = get_ctype_base(argv[1])))
|
||||
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
|
||||
|
|
@ -1334,13 +1519,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
|
||||
if (!SCHEME_INTP(argv[3]))
|
||||
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
|
||||
delta = SCHEME_INT_VAL(argv[3]);
|
||||
delta += SCHEME_INT_VAL(argv[3]);
|
||||
} else if (argc > 3) {
|
||||
if (!SCHEME_INTP(argv[2]))
|
||||
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
|
||||
delta = (size * SCHEME_INT_VAL(argv[2]));
|
||||
delta += (size * SCHEME_INT_VAL(argv[2]));
|
||||
}
|
||||
SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
|
||||
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
|
|
@ -1352,13 +1537,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
if (!SCHEME_FFIANYPTRP(argv[1]))
|
||||
scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
|
||||
return (SAME_OBJ(argv[0],argv[1]) ||
|
||||
(SCHEME_FFIANYPTR_VAL(argv[0]) == SCHEME_FFIANYPTR_VAL(argv[1])))
|
||||
((SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) == SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))))
|
||||
? scheme_true : scheme_false;
|
||||
}
|
||||
|
||||
/* (make-sized-byte-string cpointer len) */
|
||||
{:(cdefine make-sized-byte-string 2 2):}
|
||||
/* Warning: no copying is done so it is possible to share string contents. */
|
||||
/* Warning: if source ptr has a offset, resulting string object uses shifted pointer. */
|
||||
/* (Should use real byte-strings with new version.) */
|
||||
{
|
||||
long len;
|
||||
|
|
@ -1368,7 +1554,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
|
||||
if (SCHEME_FALSEP(argv[0])) return scheme_false;
|
||||
else return
|
||||
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_VAL(argv[0]), len, 0);
|
||||
scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), len, 0);
|
||||
}
|
||||
|
||||
/* internal: apply Scheme finalizer */
|
||||
|
|
@ -1442,6 +1628,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
Scheme_Object *otype = SCHEME_VEC_ELS(data)[3];
|
||||
Scheme_Object *base;
|
||||
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
|
||||
long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
|
||||
int nargs = cif->nargs;
|
||||
/* When the foreign function is called, we need an array (ivals) of nargs
|
||||
* ForeignAny objects to store the actual C values that are created, and we
|
||||
|
|
@ -1462,25 +1649,30 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
void **avalues, *p, *newp, *tmp;
|
||||
GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
|
||||
void *stack_avalues[MAX_QUICK_ARGS];
|
||||
long stack_offsets[MAX_QUICK_ARGS];
|
||||
int i;
|
||||
long basetype;
|
||||
long basetype, offset, *offsets;
|
||||
if (nargs <= MAX_QUICK_ARGS) {
|
||||
ivals = stack_ivals;
|
||||
avalues = stack_avalues;
|
||||
offsets = stack_offsets;
|
||||
} else {
|
||||
ivals = malloc(nargs * sizeof(ForeignAny));
|
||||
avalues = scheme_malloc(nargs * sizeof(void*));
|
||||
offsets = scheme_malloc(nargs * sizeof(long));
|
||||
}
|
||||
/* iterate on input values and types */
|
||||
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
|
||||
/* convert argv[i] according to current itype */
|
||||
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
|
||||
offset = 0;
|
||||
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0);
|
||||
if (p != NULL) {
|
||||
avalues[i] = p;
|
||||
ivals[i].x_fixnum = basetype; /* remember the base type */
|
||||
} else {
|
||||
avalues[i] = NULL;
|
||||
}
|
||||
offsets[i] = offset;
|
||||
}
|
||||
base = get_ctype_base(otype); /* verified below, so cannot be NULL */
|
||||
/* If this is a struct return value, then need to malloc in any case, even if
|
||||
|
|
@ -1494,7 +1686,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
p = &oval;
|
||||
newp = NULL;
|
||||
}
|
||||
/* We finished with all possible mallocs, clear up the avalues mess */
|
||||
/* We finished with all possible mallocs, clear up the avalues an offsets mess */
|
||||
for (i=0; i<nargs; i++) {
|
||||
if (avalues[i] == NULL) /* if this was a non-pointer... */
|
||||
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
|
||||
|
|
@ -1503,10 +1695,14 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
|
|||
ivals[i].x_pointer = avalues[i];
|
||||
avalues[i] = &(ivals[i]);
|
||||
}
|
||||
/* Otherwise it was a struct pointer, and avalues[i] is already fine */
|
||||
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */
|
||||
/* Add offset, if any: */
|
||||
if (offsets[i] != 0) {
|
||||
ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
|
||||
}
|
||||
}
|
||||
/* Finally, call the function */
|
||||
ffi_call(cif, c_func, p, avalues);
|
||||
ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
|
||||
if (ivals != stack_ivals) free(ivals);
|
||||
ivals = NULL; /* no need now to hold on to this */
|
||||
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
|
||||
|
|
@ -1546,6 +1742,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
Scheme_Object *itypes = argv[1];
|
||||
Scheme_Object *otype = argv[2];
|
||||
Scheme_Object *obj, *data, *p, *base;
|
||||
long ooff;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs;
|
||||
|
|
@ -1555,7 +1752,8 @@ void free_fficall_data(void *ignored, void *p)
|
|||
if (!SCHEME_FFIANYPTRP(argv[0]))
|
||||
scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
|
||||
obj = SCHEME_FFIANYPTR_VAL(argv[0]);
|
||||
if (obj == NULL)
|
||||
ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
|
||||
if ((obj == NULL) && (ooff == 0))
|
||||
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
|
||||
nargs = scheme_proper_list_length(itypes);
|
||||
if (nargs < 0)
|
||||
|
|
@ -1574,7 +1772,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
cif = malloc(sizeof(ffi_cif));
|
||||
if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
|
||||
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
|
||||
data = scheme_make_vector(5, NULL);
|
||||
data = scheme_make_vector(6, NULL);
|
||||
p = scheme_append_byte_string
|
||||
(ffi_name_prefix,
|
||||
scheme_make_byte_string_without_copying
|
||||
|
|
@ -1585,6 +1783,7 @@ void free_fficall_data(void *ignored, void *p)
|
|||
SCHEME_VEC_ELS(data)[2] = itypes;
|
||||
SCHEME_VEC_ELS(data)[3] = otype;
|
||||
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
|
||||
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
|
||||
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
|
||||
return scheme_make_closed_prim_w_arity
|
||||
(ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
|
||||
|
|
@ -1619,7 +1818,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
|
|||
argv[i] = v;
|
||||
}
|
||||
p = _scheme_apply(data->proc, argc, argv);
|
||||
SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
|
||||
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
|
||||
}
|
||||
|
||||
/* see ffi-callback below */
|
||||
|
|
|
|||
|
|
@ -121,7 +121,8 @@ XFORMDEP_NOPRECOMP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss
|
|||
XFORMDEP = $(XFORMDEP_NOPRECOMP) $(XSRCDIR)/precomp.h
|
||||
|
||||
$(XSRCDIR)/precomp.h : $(XFORMDEP_NOPRECOMP) $(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \
|
||||
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h $(srcdir)/../src/schemef.h
|
||||
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h $(srcdir)/../src/schemef.h \
|
||||
$(srcdir)/../src/stypes.h
|
||||
env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c
|
||||
|
||||
$(XSRCDIR)/salloc.c: ../src/salloc.@LTO@ $(XFORMDEP)
|
||||
|
|
|
|||
|
|
@ -3884,6 +3884,11 @@ void *GC_malloc_allow_interior(size_t size_in_bytes)
|
|||
return malloc_bigblock(size_in_bytes, MTYPE_ARRAY, 1);
|
||||
}
|
||||
|
||||
void *GC_malloc_atomic_allow_interior(size_t size_in_bytes)
|
||||
{
|
||||
return malloc_bigblock(size_in_bytes, MTYPE_ATOMIC, 1);
|
||||
}
|
||||
|
||||
void *GC_malloc_tagged_allow_interior(size_t size_in_bytes)
|
||||
{
|
||||
return malloc_bigblock(size_in_bytes, MTYPE_TAGGED, 1);
|
||||
|
|
|
|||
|
|
@ -180,6 +180,10 @@ GC2_EXTERN void *GC_malloc_allow_interior(size_t size_in_bytes);
|
|||
pointers into the middle of the array, or just past the end of the
|
||||
array. */
|
||||
|
||||
GC2_EXTERN void *GC_malloc_atomic_allow_interior(size_t size_in_bytes);
|
||||
/*
|
||||
Like GC_malloc_allow_interior(), but for an atomic object. */
|
||||
|
||||
GC2_EXTERN void *GC_malloc_tagged_allow_interior(size_t size_in_bytes);
|
||||
/*
|
||||
Like GC_malloc_allow_interior(), but for a tagged object. */
|
||||
|
|
|
|||
|
|
@ -491,6 +491,7 @@ void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); }
|
|||
void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); }
|
||||
void *GC_malloc_atomic_uncollectable(size_t s) { return malloc(s); }
|
||||
void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);}
|
||||
void *GC_malloc_atomic_allow_interior(size_t s) {return allocate_big(s, PAGE_ATOMIC);}
|
||||
void *GC_malloc_tagged_allow_interior(size_t s) {return allocate_big(s, PAGE_TAGGED);}
|
||||
void GC_free(void *p) {}
|
||||
|
||||
|
|
|
|||
|
|
@ -265,6 +265,7 @@ scheme_get_long_long_val
|
|||
scheme_get_unsigned_long_long_val
|
||||
scheme_real_to_double
|
||||
scheme_make_cptr
|
||||
scheme_make_offset_cptr
|
||||
scheme_get_proc_name
|
||||
scheme_utf8_decode
|
||||
scheme_utf8_decode_as_prefix
|
||||
|
|
@ -487,6 +488,7 @@ scheme_eqv
|
|||
scheme_equal
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_set_type_equality
|
||||
scheme_build_list
|
||||
scheme_build_list_offset
|
||||
scheme_make_list_immutable
|
||||
|
|
|
|||
|
|
@ -164,6 +164,9 @@ GC_malloc_one_tagged
|
|||
GC_malloc_atomic_uncollectable
|
||||
scheme_malloc_uncollectable
|
||||
GC_malloc_array_tagged
|
||||
GC_malloc_allow_interior
|
||||
GC_malloc_atomic_allow_interior
|
||||
GC_malloc_tagged_allow_interior
|
||||
scheme_malloc_eternal
|
||||
scheme_end_stubborn_change
|
||||
scheme_calloc
|
||||
|
|
@ -272,6 +275,7 @@ scheme_get_long_long_val
|
|||
scheme_get_unsigned_long_long_val
|
||||
scheme_real_to_double
|
||||
scheme_make_cptr
|
||||
scheme_make_offset_cptr
|
||||
scheme_get_proc_name
|
||||
scheme_utf8_decode
|
||||
scheme_utf8_decode_as_prefix
|
||||
|
|
@ -495,6 +499,7 @@ scheme_equal
|
|||
scheme_hash_key
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_set_type_equality
|
||||
scheme_build_list
|
||||
scheme_build_list_offset
|
||||
scheme_make_list_immutable
|
||||
|
|
|
|||
|
|
@ -253,6 +253,7 @@ EXPORTS
|
|||
scheme_get_unsigned_long_long_val
|
||||
scheme_real_to_double
|
||||
scheme_make_cptr
|
||||
scheme_make_offset_cptr
|
||||
scheme_get_proc_name
|
||||
scheme_utf8_decode
|
||||
scheme_utf8_decode_as_prefix
|
||||
|
|
@ -475,6 +476,7 @@ EXPORTS
|
|||
scheme_equal
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_set_type_equality
|
||||
scheme_build_list
|
||||
scheme_build_list_offset
|
||||
scheme_make_list_immutable
|
||||
|
|
|
|||
|
|
@ -156,6 +156,9 @@ EXPORTS
|
|||
GC_malloc_atomic_uncollectable
|
||||
scheme_malloc_uncollectable
|
||||
GC_malloc_array_tagged
|
||||
GC_malloc_allow_interior
|
||||
GC_malloc_atomic_allow_interior
|
||||
GC_malloc_tagged_allow_interior
|
||||
scheme_malloc_eternal
|
||||
scheme_end_stubborn_change
|
||||
scheme_calloc
|
||||
|
|
@ -264,6 +267,7 @@ EXPORTS
|
|||
scheme_get_unsigned_long_long_val
|
||||
scheme_real_to_double
|
||||
scheme_make_cptr
|
||||
scheme_make_offset_cptr
|
||||
scheme_get_proc_name
|
||||
scheme_utf8_decode
|
||||
scheme_utf8_decode_as_prefix
|
||||
|
|
@ -487,6 +491,7 @@ EXPORTS
|
|||
scheme_hash_key
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_set_type_equality
|
||||
scheme_build_list
|
||||
scheme_build_list_offset
|
||||
scheme_make_list_immutable
|
||||
|
|
|
|||
|
|
@ -325,6 +325,10 @@ typedef struct Scheme_Vector {
|
|||
typedef struct Scheme_Print_Params Scheme_Print_Params;
|
||||
typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
|
||||
|
||||
typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base);
|
||||
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
|
||||
|
||||
/* This file defines all the built-in types */
|
||||
#ifdef INCLUDE_WITHOUT_PATHS
|
||||
# include "stypes.h"
|
||||
|
|
@ -459,7 +463,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
#define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
|
||||
#define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
|
||||
|
||||
#define SCHEME_CPTRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type)
|
||||
#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_offset_cpointer_type))
|
||||
|
||||
#define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1))
|
||||
#define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)
|
||||
|
|
@ -549,8 +553,21 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
#define SCHEME_PINT_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.pint)
|
||||
#define SCHEME_PLONG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.pint)
|
||||
|
||||
#define SCHEME_CPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.cptr_val.val)
|
||||
#define SCHEME_CPTR_TYPE(obj) (((Scheme_Simple_Object *)(obj))->u.cptr_val.type)
|
||||
typedef struct Scheme_Cptr
|
||||
{
|
||||
Scheme_Object so;
|
||||
void *val;
|
||||
Scheme_Object *type;
|
||||
} Scheme_Cptr;
|
||||
typedef struct Scheme_Offset_Cptr
|
||||
{
|
||||
Scheme_Cptr cptr;
|
||||
long offset;
|
||||
} Scheme_Offset_Cptr;
|
||||
|
||||
#define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
|
||||
#define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
|
||||
#define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
|
||||
|
||||
#define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
|
||||
#define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
|
||||
|
|
@ -1515,6 +1532,7 @@ void *scheme_malloc(size_t size);
|
|||
# define scheme_malloc_weak GC_malloc_weak
|
||||
# define scheme_malloc_weak_tagged GC_malloc_one_weak_tagged
|
||||
# define scheme_malloc_allow_interior GC_malloc_allow_interior
|
||||
# define scheme_malloc_atomic_allow_interior GC_malloc_allow_interior
|
||||
#else
|
||||
# ifdef USE_TAGGED_ALLOCATION
|
||||
extern void *scheme_malloc_tagged(size_t);
|
||||
|
|
@ -1537,6 +1555,7 @@ extern void *scheme_malloc_envunbox(size_t);
|
|||
# endif
|
||||
# define scheme_malloc_small_dirty_tagged scheme_malloc_small_tagged
|
||||
# define scheme_malloc_allow_interior scheme_malloc
|
||||
# define scheme_malloc_atomic_allow_interior scheme_malloc_atomic
|
||||
# define scheme_malloc_small_atomic_tagged scheme_malloc_atomic_tagged
|
||||
#endif
|
||||
|
||||
|
|
|
|||
|
|
@ -272,8 +272,13 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
|
|||
return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2);
|
||||
} else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
|
||||
return vector_equal(obj1, obj2);
|
||||
} else
|
||||
return 0;
|
||||
} else {
|
||||
Scheme_Equal_Proc eql = scheme_type_equals[SCHEME_TYPE(obj1)];
|
||||
if (eql)
|
||||
return eql(obj1, obj2);
|
||||
else
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -154,6 +154,20 @@ static void init_compile_data(Scheme_Comp_Env *env);
|
|||
/* initialization */
|
||||
/*========================================================================*/
|
||||
|
||||
|
||||
#ifdef DONT_USE_FOREIGN
|
||||
static void init_dummy_foreign(Scheme *env)
|
||||
{
|
||||
/* Works just well enough that the `mzscheme' module can
|
||||
import it (so that attaching `mzscheme' to a namespace
|
||||
also attaches `#%foreign'). */
|
||||
Scheme_Env *menv;
|
||||
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
|
||||
scheme_finish_primitive_module(menv);
|
||||
scheme_protect_primitive_provide(menv, NULL);
|
||||
}
|
||||
#endif
|
||||
|
||||
Scheme_Env *scheme_basic_env()
|
||||
{
|
||||
Scheme_Env *env;
|
||||
|
|
@ -350,6 +364,8 @@ Scheme_Env *scheme_basic_env()
|
|||
|
||||
#ifndef DONT_USE_FOREIGN
|
||||
scheme_init_foreign(env);
|
||||
#else
|
||||
init_dummy_foreign(env);
|
||||
#endif
|
||||
|
||||
scheme_add_embedded_builtins(env);
|
||||
|
|
|
|||
|
|
@ -172,6 +172,7 @@ static Scheme_Object *compile(int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *expand(int argc, Scheme_Object **argv);
|
||||
static Scheme_Object *local_expand(int argc, Scheme_Object **argv);
|
||||
static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv);
|
||||
static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv);
|
||||
static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv);
|
||||
static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv);
|
||||
|
|
@ -387,6 +388,11 @@ scheme_init_eval (Scheme_Env *env)
|
|||
"local-expand",
|
||||
3, 4),
|
||||
env);
|
||||
scheme_add_global_constant("syntax-local-expand-expression",
|
||||
scheme_make_prim_w_arity(local_expand_expr,
|
||||
"syntax-local-expand-expression",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("syntax-local-bind-syntaxes",
|
||||
scheme_make_prim_w_arity(local_eval,
|
||||
"syntax-local-bind-syntaxes",
|
||||
|
|
@ -3975,6 +3981,18 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m
|
|||
/* caller expects rec[drec] to be used to compile the result... */
|
||||
}
|
||||
|
||||
static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e)
|
||||
{
|
||||
while (1) {
|
||||
if (orig == e)
|
||||
return 1;
|
||||
if (e && e->flags & SCHEME_FOR_STOPS)
|
||||
e = e->next;
|
||||
else
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
static Scheme_Object *compile_expand_expr_k(void)
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
|
|
@ -4045,6 +4063,22 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form);
|
||||
}
|
||||
|
||||
if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) {
|
||||
var = SCHEME_STX_VAL(form);
|
||||
if (scheme_stx_has_empty_wraps(form)
|
||||
&& same_effective_env(SCHEME_PTR2_VAL(var), env)) {
|
||||
/* FIXME: this needs EXPAND_OBSERVE callbacks. */
|
||||
var = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form);
|
||||
form = scheme_stx_cert(var, scheme_false, NULL, form, NULL, 1);
|
||||
if (!rec[drec].comp) {
|
||||
/* Already fully expanded. */
|
||||
return form;
|
||||
}
|
||||
} else {
|
||||
scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), "expanded syntax not in its original context");
|
||||
}
|
||||
}
|
||||
|
||||
looking_for_top = 0;
|
||||
|
||||
if (SCHEME_STX_NULLP(form)) {
|
||||
|
|
@ -7655,15 +7689,16 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
|
|||
}
|
||||
|
||||
static Scheme_Object *
|
||||
do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme_Object **argv)
|
||||
do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
|
||||
{
|
||||
Scheme_Comp_Env *env;
|
||||
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l;
|
||||
Scheme_Comp_Env *env, *orig_env;
|
||||
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
|
||||
int cnt, pos, kind;
|
||||
int bad_sub_env = 0;
|
||||
Scheme_Object *observer;
|
||||
|
||||
env = scheme_current_thread->current_local_env;
|
||||
orig_env = env;
|
||||
|
||||
if (!env)
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: not currently transforming", name);
|
||||
|
|
@ -7673,7 +7708,9 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
|
|||
env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
|
||||
}
|
||||
|
||||
if (SAME_OBJ(argv[1], module_symbol))
|
||||
if (for_expr)
|
||||
kind = 0; /* expression */
|
||||
else if (SAME_OBJ(argv[1], module_symbol))
|
||||
kind = SCHEME_MODULE_BEGIN_FRAME; /* name is backwards compared to symbol! */
|
||||
else if (SAME_OBJ(argv[1], module_begin_symbol))
|
||||
kind = SCHEME_MODULE_FRAME; /* name is backwards compared to symbol! */
|
||||
|
|
@ -7718,7 +7755,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
|
|||
|
||||
local_mark = scheme_current_thread->current_local_mark;
|
||||
|
||||
if (SCHEME_TRUEP(argv[2])) {
|
||||
if (for_expr) {
|
||||
} else if (SCHEME_TRUEP(argv[2])) {
|
||||
cnt = scheme_stx_proper_list_length(argv[2]);
|
||||
if (cnt > 0)
|
||||
scheme_add_local_syntax(cnt, env);
|
||||
|
|
@ -7804,6 +7842,25 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
|
|||
if (renaming)
|
||||
l = scheme_add_rename(l, renaming);
|
||||
|
||||
if (for_expr) {
|
||||
/* Package up expanded expr with the enviornment. */
|
||||
while (1) {
|
||||
if (orig_env->flags & SCHEME_FOR_STOPS)
|
||||
orig_env = orig_env->next;
|
||||
else if ((orig_env->flags & SCHEME_INTDEF_FRAME)
|
||||
&& !orig_env->num_bindings)
|
||||
orig_env = orig_env->next;
|
||||
else
|
||||
break;
|
||||
}
|
||||
exp_expr = scheme_alloc_object();
|
||||
exp_expr->type = scheme_expanded_syntax_type;
|
||||
SCHEME_PTR1_VAL(exp_expr) = l;
|
||||
SCHEME_PTR2_VAL(exp_expr) = orig_env;
|
||||
exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0);
|
||||
exp_expr = scheme_add_remove_mark(exp_expr, local_mark);
|
||||
}
|
||||
|
||||
if (local_mark) {
|
||||
/* Put the temporary mark back: */
|
||||
l = scheme_add_remove_mark(l, local_mark);
|
||||
|
|
@ -7811,31 +7868,43 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
|
|||
|
||||
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
|
||||
|
||||
return l;
|
||||
if (for_expr) {
|
||||
Scheme_Object *a[2];
|
||||
a[0] = l;
|
||||
a[1] = exp_expr;
|
||||
return scheme_values(2, a);
|
||||
} else
|
||||
return l;
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
local_expand(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_local_expand("local-expand", 0, 0, argc, argv);
|
||||
return do_local_expand("local-expand", 0, 0, 0, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
local_expand_expr(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_local_expand("syntax-local-expand-expression", 0, 0, 1, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
local_transformer_expand(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_local_expand("local-transformer-expand", 1, 0, argc, argv);
|
||||
return do_local_expand("local-transformer-expand", 1, 0, 0, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
local_expand_catch_lifts(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_local_expand("local-expand/capture-lifts", 0, 1, argc, argv);
|
||||
return do_local_expand("local-expand/capture-lifts", 0, 1, 0, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, argc, argv);
|
||||
return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, 0, argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
|
|
|
|||
|
|
@ -3288,6 +3288,25 @@ static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
|
|||
return SCHEME_TAIL_CALL_WAITING;
|
||||
}
|
||||
|
||||
static MZ_INLINE Scheme_Object *values_slow(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
Scheme_Object **a;
|
||||
int i;
|
||||
|
||||
a = MALLOC_N(Scheme_Object *, argc);
|
||||
p->values_buffer = a;
|
||||
p->values_buffer_size = argc;
|
||||
|
||||
p->ku.multiple.array = a;
|
||||
|
||||
for (i = 0; i < argc; i++) {
|
||||
a[i] = argv[i];
|
||||
}
|
||||
|
||||
return SCHEME_MULTIPLE_VALUES;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Thread *p;
|
||||
|
|
@ -3299,12 +3318,10 @@ Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
|
|||
|
||||
p = scheme_current_thread;
|
||||
p->ku.multiple.count = argc;
|
||||
if (p->values_buffer && (p->values_buffer_size >= argc))
|
||||
if (p->values_buffer && (p->values_buffer_size >= argc)) {
|
||||
a = p->values_buffer;
|
||||
else {
|
||||
a = MALLOC_N(Scheme_Object *, argc);
|
||||
p->values_buffer = a;
|
||||
p->values_buffer_size = argc;
|
||||
} else {
|
||||
return values_slow(argc, argv);
|
||||
}
|
||||
|
||||
p->ku.multiple.array = a;
|
||||
|
|
|
|||
|
|
@ -1080,7 +1080,13 @@ static long equal_hash_key(Scheme_Object *o, long k)
|
|||
}
|
||||
# endif
|
||||
default:
|
||||
return k + (PTR_TO_LONG(o) >> 4);
|
||||
{
|
||||
Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t];
|
||||
if (h1)
|
||||
return h1(o, k);
|
||||
else
|
||||
return k + (PTR_TO_LONG(o) >> 4);
|
||||
}
|
||||
}
|
||||
|
||||
k = (k << 1) + k;
|
||||
|
|
@ -1274,6 +1280,12 @@ long scheme_equal_hash_key2(Scheme_Object *o)
|
|||
return k;
|
||||
}
|
||||
default:
|
||||
return t;
|
||||
{
|
||||
Scheme_Secondary_Hash_Proc h2 = scheme_type_hash2s[t];
|
||||
if (h2)
|
||||
return h2(o);
|
||||
else
|
||||
return t;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -107,6 +107,7 @@ static void *call_original_binary_arith_for_branch_code;
|
|||
static void *call_original_binary_rev_arith_for_branch_code;
|
||||
static void *bad_car_code, *bad_cdr_code;
|
||||
static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code;
|
||||
static void *bad_set_car_code, *bad_set_cdr_code;
|
||||
static void *bad_unbox_code;
|
||||
static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
|
||||
static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
|
||||
|
|
@ -1897,7 +1898,9 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina)
|
||||
&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)
|
||||
|| (((Scheme_Primitive_Proc *)rator)->mina < 0))
|
||||
&& is_noncm(rator, jitter, 0, 0))
|
||||
&& (is_noncm(rator, jitter, 0, 0)
|
||||
/* It's also ok to directly call `values' if multiple values are ok: */
|
||||
|| (multi_ok && SAME_OBJ(rator, scheme_values_func))))
|
||||
direct_prim = 1;
|
||||
} else {
|
||||
Scheme_Type t;
|
||||
|
|
@ -3260,6 +3263,43 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
else
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "set-car!")
|
||||
|| IS_NAMED_PRIM(rator, "set-cdr!")) {
|
||||
GC_CAN_IGNORE jit_insn *reffail, *ref;
|
||||
int set_car;
|
||||
|
||||
set_car = IS_NAMED_PRIM(rator, "set-car!");
|
||||
|
||||
LOG_IT(("inlined set-car!\n"));
|
||||
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
CHECK_LIMIT();
|
||||
|
||||
__START_SHORT_JUMPS__(1);
|
||||
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
|
||||
reffail = _jit.x.pc;
|
||||
__END_SHORT_JUMPS__(1);
|
||||
if (set_car)
|
||||
(void)jit_jmpi(bad_set_car_code);
|
||||
else
|
||||
(void)jit_jmpi(bad_set_cdr_code);
|
||||
__START_SHORT_JUMPS__(1);
|
||||
mz_patch_branch(ref);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
(void)jit_bnei_i(reffail, JIT_R2, scheme_pair_type);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)0x0)));
|
||||
(void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
|
||||
__END_SHORT_JUMPS__(1);
|
||||
CHECK_LIMIT();
|
||||
|
||||
if (set_car)
|
||||
(void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.car, JIT_R0, JIT_R1);
|
||||
else
|
||||
(void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.cdr, JIT_R0, JIT_R1);
|
||||
|
||||
(void)jit_movi_p(JIT_R0, scheme_void);
|
||||
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "cons")) {
|
||||
LOG_IT(("inlined cons\n"));
|
||||
|
|
@ -4830,6 +4870,37 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
CHECK_LIMIT();
|
||||
}
|
||||
|
||||
/* *** bad_set_{car,cdr}_code *** */
|
||||
/* Bad argument is in R0, other is in R1 */
|
||||
for (i = 0; i < 2; i++) {
|
||||
switch (i) {
|
||||
case 0:
|
||||
bad_set_car_code = jit_get_ip().ptr;
|
||||
break;
|
||||
case 1:
|
||||
bad_set_cdr_code = jit_get_ip().ptr;
|
||||
break;
|
||||
}
|
||||
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
|
||||
jit_str_p(JIT_RUNSTACK, JIT_R0);
|
||||
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
CHECK_LIMIT();
|
||||
jit_movi_i(JIT_R1, 2);
|
||||
jit_prepare(2);
|
||||
jit_pusharg_p(JIT_RUNSTACK);
|
||||
jit_pusharg_i(JIT_R1);
|
||||
switch (i) {
|
||||
case 0:
|
||||
(void)mz_finish(scheme_checked_set_car);
|
||||
break;
|
||||
case 1:
|
||||
(void)mz_finish(scheme_checked_set_cdr);
|
||||
break;
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
}
|
||||
|
||||
/* *** bad_unbox_code *** */
|
||||
/* R0 is argument */
|
||||
bad_unbox_code = jit_get_ip().ptr;
|
||||
|
|
|
|||
|
|
@ -30,8 +30,6 @@ Scheme_Object scheme_null[1];
|
|||
/* locals */
|
||||
static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *cons_prim (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *set_car_prim (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *set_cdr_prim (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *cons_immutable (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *null_p_prim (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *list_p_prim (int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -138,16 +136,14 @@ scheme_init_list (Scheme_Env *env)
|
|||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
scheme_add_global_constant ("cdr", p, env);
|
||||
|
||||
scheme_add_global_constant ("set-car!",
|
||||
scheme_make_noncm_prim(set_car_prim,
|
||||
"set-car!",
|
||||
2, 2),
|
||||
env);
|
||||
scheme_add_global_constant ("set-cdr!",
|
||||
scheme_make_noncm_prim(set_cdr_prim,
|
||||
"set-cdr!",
|
||||
2, 2),
|
||||
env);
|
||||
p = scheme_make_noncm_prim(scheme_checked_set_car, "set-car!", 2, 2);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
|
||||
scheme_add_global_constant ("set-car!", p, env);
|
||||
|
||||
p = scheme_make_noncm_prim(scheme_checked_set_cdr, "set-cdr!", 2, 2);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
|
||||
scheme_add_global_constant ("set-cdr!", p, env);
|
||||
|
||||
scheme_add_global_constant ("cons-immutable",
|
||||
scheme_make_noncm_prim(cons_immutable,
|
||||
"cons-immutable",
|
||||
|
|
@ -766,8 +762,8 @@ scheme_checked_cdr (int argc, Scheme_Object *argv[])
|
|||
return (SCHEME_CDR (argv[0]));
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
set_car_prim (int argc, Scheme_Object *argv[])
|
||||
Scheme_Object *
|
||||
scheme_checked_set_car (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
if (!SCHEME_MUTABLE_PAIRP(argv[0]))
|
||||
scheme_wrong_type("set-car!", "mutable-pair", 0, argc, argv);
|
||||
|
|
@ -776,8 +772,8 @@ set_car_prim (int argc, Scheme_Object *argv[])
|
|||
return scheme_void;
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
set_cdr_prim (int argc, Scheme_Object *argv[])
|
||||
Scheme_Object *
|
||||
scheme_checked_set_cdr (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
if (!SCHEME_MUTABLE_PAIRP(argv[0]))
|
||||
scheme_wrong_type("set-cdr!", "mutable-pair", 0, argc, argv);
|
||||
|
|
|
|||
|
|
@ -152,27 +152,50 @@ static int quotesyntax_obj_FIXUP(void *p) {
|
|||
|
||||
static int cpointer_obj_SIZE(void *p) {
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
|
||||
}
|
||||
|
||||
static int cpointer_obj_MARK(void *p) {
|
||||
gcMARK(SCHEME_CPTR_VAL((Scheme_Object *)p));
|
||||
gcMARK(SCHEME_CPTR_TYPE((Scheme_Object *)p));
|
||||
gcMARK(SCHEME_CPTR_VAL(p));
|
||||
gcMARK(SCHEME_CPTR_TYPE(p));
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
|
||||
}
|
||||
|
||||
static int cpointer_obj_FIXUP(void *p) {
|
||||
gcFIXUP(SCHEME_CPTR_VAL((Scheme_Object *)p));
|
||||
gcFIXUP(SCHEME_CPTR_TYPE((Scheme_Object *)p));
|
||||
gcFIXUP(SCHEME_CPTR_VAL(p));
|
||||
gcFIXUP(SCHEME_CPTR_TYPE(p));
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
|
||||
}
|
||||
|
||||
#define cpointer_obj_IS_ATOMIC 0
|
||||
#define cpointer_obj_IS_CONST_SIZE 1
|
||||
|
||||
|
||||
static int offset_cpointer_obj_SIZE(void *p) {
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
|
||||
}
|
||||
|
||||
static int offset_cpointer_obj_MARK(void *p) {
|
||||
gcMARK(SCHEME_CPTR_VAL(p));
|
||||
gcMARK(SCHEME_CPTR_TYPE(p));
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
|
||||
}
|
||||
|
||||
static int offset_cpointer_obj_FIXUP(void *p) {
|
||||
gcFIXUP(SCHEME_CPTR_VAL(p));
|
||||
gcFIXUP(SCHEME_CPTR_TYPE(p));
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
|
||||
}
|
||||
|
||||
#define offset_cpointer_obj_IS_ATOMIC 0
|
||||
#define offset_cpointer_obj_IS_CONST_SIZE 1
|
||||
|
||||
|
||||
static int second_of_cons_SIZE(void *p) {
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
|
||||
|
|
|
|||
|
|
@ -56,10 +56,18 @@ quotesyntax_obj {
|
|||
|
||||
cpointer_obj {
|
||||
mark:
|
||||
gcMARK(SCHEME_CPTR_VAL((Scheme_Object *)p));
|
||||
gcMARK(SCHEME_CPTR_TYPE((Scheme_Object *)p));
|
||||
gcMARK(SCHEME_CPTR_VAL(p));
|
||||
gcMARK(SCHEME_CPTR_TYPE(p));
|
||||
size:
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
|
||||
}
|
||||
|
||||
offset_cpointer_obj {
|
||||
mark:
|
||||
gcMARK(SCHEME_CPTR_VAL(p));
|
||||
gcMARK(SCHEME_CPTR_TYPE(p));
|
||||
size:
|
||||
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
|
||||
}
|
||||
|
||||
second_of_cons {
|
||||
|
|
|
|||
|
|
@ -553,6 +553,14 @@ static Scheme_Object *name ## __wrong_type(const Scheme_Object *v) \
|
|||
scheme_wrong_type(scheme_name, "exact integer", -1, 0, a); \
|
||||
return NULL; \
|
||||
} \
|
||||
static MZ_INLINE Scheme_Object * name ## __int_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
|
||||
Small_Bignum sb; \
|
||||
return bigop((scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb)), n2); \
|
||||
} \
|
||||
static MZ_INLINE Scheme_Object * name ## __big_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
|
||||
Small_Bignum sb; \
|
||||
return bigop(n1, (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \
|
||||
} \
|
||||
static Scheme_Object * \
|
||||
name (const Scheme_Object *n1, const Scheme_Object *n2) \
|
||||
{ \
|
||||
|
|
@ -563,13 +571,11 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
|
|||
b = SCHEME_INT_VAL(n2); \
|
||||
return scheme_make_integer(a op b); \
|
||||
} else if (SCHEME_BIGNUMP(n2)) { \
|
||||
Small_Bignum sb; \
|
||||
return bigop(scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb), n2); \
|
||||
return name ## __int_big(n1, n2); \
|
||||
} \
|
||||
} else if (SCHEME_BIGNUMP(n1)) { \
|
||||
if (SCHEME_INTP(n2)) { \
|
||||
Small_Bignum sb; \
|
||||
return bigop(n1, scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb)); \
|
||||
return name ## __big_int(n1, n2); \
|
||||
} \
|
||||
if (SCHEME_BIGNUMP(n2)) \
|
||||
return bigop(n1, n2); \
|
||||
|
|
|
|||
|
|
@ -89,6 +89,7 @@ static Scheme_Object *print_honu(int, Scheme_Object *[]);
|
|||
#define RETURN_FOR_HASH_COMMENT 0x2
|
||||
#define RETURN_FOR_DELIM 0x4
|
||||
#define RETURN_FOR_COMMENT 0x8
|
||||
#define RETURN_HONU_ANGLE 0x10
|
||||
|
||||
static MZ_INLINE long SPAN(Scheme_Object *port, long pos) {
|
||||
long cpos;
|
||||
|
|
@ -303,13 +304,16 @@ static Scheme_Object *unsyntax_splicing_symbol;
|
|||
static Scheme_Object *quasisyntax_symbol;
|
||||
|
||||
static Scheme_Object *honu_comma, *honu_semicolon;
|
||||
static Scheme_Object *honu_parens, *honu_braces, *honu_brackets;
|
||||
static Scheme_Object *honu_parens, *honu_braces, *honu_brackets, *honu_angles;
|
||||
|
||||
static Scheme_Object *paren_shape_symbol;
|
||||
|
||||
static Scheme_Object *terminating_macro_symbol, *non_terminating_macro_symbol, *dispatch_macro_symbol;
|
||||
static char *builtin_fast;
|
||||
|
||||
/* For matching angle brackets in Honu mode: */
|
||||
static Scheme_Object *honu_angle_open, *honu_angle_close;
|
||||
|
||||
/* For recoginizing unresolved hash tables and commented-out graph introductions: */
|
||||
static Scheme_Object *an_uninterned_symbol;
|
||||
|
||||
|
|
@ -361,12 +365,18 @@ void scheme_init_read(Scheme_Env *env)
|
|||
REGISTER_SO(honu_parens);
|
||||
REGISTER_SO(honu_braces);
|
||||
REGISTER_SO(honu_brackets);
|
||||
REGISTER_SO(honu_angles);
|
||||
REGISTER_SO(honu_angle_open);
|
||||
REGISTER_SO(honu_angle_close);
|
||||
|
||||
honu_comma = scheme_intern_symbol(",");
|
||||
honu_semicolon = scheme_intern_symbol(";");
|
||||
honu_parens = scheme_intern_symbol("#%parens");
|
||||
honu_braces = scheme_intern_symbol("#%braces");
|
||||
honu_brackets = scheme_intern_symbol("#%brackets");
|
||||
honu_angles = scheme_intern_symbol("#%angles");
|
||||
honu_angle_open = scheme_make_symbol("<"); /* uninterned */
|
||||
honu_angle_close = scheme_make_symbol(">"); /* uninterned */
|
||||
|
||||
{
|
||||
int i;
|
||||
|
|
@ -1687,6 +1697,28 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
|
|||
}
|
||||
special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
|
||||
break;
|
||||
case '>':
|
||||
case '<':
|
||||
if ((params->honu_mode) && (comment_mode & RETURN_HONU_ANGLE)) {
|
||||
Scheme_Object *v;
|
||||
v = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
|
||||
special_value = v;
|
||||
if (SCHEME_STXP(v))
|
||||
v = SCHEME_STX_VAL(v);
|
||||
if (SCHEME_SYMBOLP(v) && (SCHEME_SYM_LEN(v) == 1)
|
||||
&& ((SCHEME_SYM_VAL(v)[0] == '>') || (SCHEME_SYM_VAL(v)[0] == '<'))) {
|
||||
if (SCHEME_SYM_VAL(v)[0] == '<')
|
||||
v = honu_angle_open;
|
||||
else
|
||||
v = honu_angle_close;
|
||||
if (SCHEME_STXP(special_value))
|
||||
special_value = scheme_datum_to_syntax(v, scheme_false, special_value, 0, 1);
|
||||
else
|
||||
special_value = v;
|
||||
}
|
||||
} else
|
||||
special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
|
||||
break;
|
||||
default:
|
||||
if (isdigit_ascii(ch))
|
||||
special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
|
||||
|
|
@ -2220,6 +2252,7 @@ static const char *dot_name(ReadParams *params)
|
|||
return mapping_name(params, '.', "`.'", 6);
|
||||
}
|
||||
|
||||
static Scheme_Object *combine_angle_brackets(Scheme_Object *list);
|
||||
static Scheme_Object *honu_add_module_wrapper(Scheme_Object *list,
|
||||
Scheme_Object *stxsrc,
|
||||
Scheme_Object *port);
|
||||
|
|
@ -2322,6 +2355,7 @@ read_list(Scheme_Object *port,
|
|||
}
|
||||
}
|
||||
pop_indentation(indentation);
|
||||
list = combine_angle_brackets(list);
|
||||
list = (stxsrc
|
||||
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
|
||||
: list);
|
||||
|
|
@ -2344,7 +2378,8 @@ read_list(Scheme_Object *port,
|
|||
to make sure that it's not a comment. For consistency, always
|
||||
read ahead. */
|
||||
scheme_ungetc(ch, port);
|
||||
prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
|
||||
prefetched = read_inner(port, stxsrc, ht, indentation, params,
|
||||
RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
|
||||
if (!prefetched)
|
||||
continue; /* It was a comment; try again. */
|
||||
|
||||
|
|
@ -2376,7 +2411,8 @@ read_list(Scheme_Object *port,
|
|||
prefetched = NULL;
|
||||
} else {
|
||||
scheme_ungetc(ch, port);
|
||||
car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
|
||||
car = read_inner(port, stxsrc, ht, indentation, params,
|
||||
RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
|
||||
if (!car) continue; /* special was a comment */
|
||||
}
|
||||
/* can't be eof, due to check above */
|
||||
|
|
@ -2428,6 +2464,8 @@ read_list(Scheme_Object *port,
|
|||
}
|
||||
|
||||
pop_indentation(indentation);
|
||||
if (params->honu_mode)
|
||||
list = combine_angle_brackets(list);
|
||||
list = (stxsrc
|
||||
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
|
||||
: list);
|
||||
|
|
@ -2450,7 +2488,7 @@ read_list(Scheme_Object *port,
|
|||
return NULL;
|
||||
}
|
||||
/* can't be eof, due to check above: */
|
||||
cdr = read_inner(port, stxsrc, ht, indentation, params, 0);
|
||||
cdr = read_inner(port, stxsrc, ht, indentation, params, RETURN_HONU_ANGLE);
|
||||
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
|
||||
effective_ch = readtable_effective_char(params->table, ch);
|
||||
if (effective_ch != closer) {
|
||||
|
|
@ -2503,7 +2541,8 @@ read_list(Scheme_Object *port,
|
|||
/* Assert: infixed is NULL (otherwise we raised an exception above) */
|
||||
|
||||
pop_indentation(indentation);
|
||||
|
||||
if (params->honu_mode)
|
||||
list = combine_angle_brackets(list);
|
||||
list = (stxsrc
|
||||
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
|
||||
: list);
|
||||
|
|
@ -2514,7 +2553,8 @@ read_list(Scheme_Object *port,
|
|||
if ((ch == SCHEME_SPECIAL) || (params->table && (ch != EOF))) {
|
||||
/* We have to try the read, because it might be a comment. */
|
||||
scheme_ungetc(ch, port);
|
||||
prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
|
||||
prefetched = read_inner(port, stxsrc, ht, indentation, params,
|
||||
RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
|
||||
if (!prefetched)
|
||||
goto retry_before_dot;
|
||||
} else {
|
||||
|
|
@ -2538,6 +2578,87 @@ read_list(Scheme_Object *port,
|
|||
}
|
||||
}
|
||||
|
||||
static Scheme_Object *combine_angle_brackets(Scheme_Object *list)
|
||||
{
|
||||
Scheme_Object *l, *a, *open_stack = NULL, *prev = NULL;
|
||||
int i, ch;
|
||||
|
||||
for (l = list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
|
||||
a = SCHEME_CAR(l);
|
||||
if (SCHEME_STXP(a))
|
||||
a = SCHEME_STX_VAL(a);
|
||||
if (SAME_OBJ(a, honu_angle_open)) {
|
||||
open_stack = scheme_make_raw_pair(scheme_make_raw_pair(l, prev),
|
||||
open_stack);
|
||||
/* Tentatively assume no matching close: */
|
||||
a = scheme_intern_symbol("<");
|
||||
if (SCHEME_STXP(SCHEME_CAR(l)))
|
||||
a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
|
||||
SCHEME_CAR(l) = a;
|
||||
} else if (SAME_OBJ(a, honu_angle_close)) {
|
||||
if (open_stack) {
|
||||
/* A matching close --- combine the angle brackets! */
|
||||
Scheme_Object *open, *open_prev;
|
||||
Scheme_Object *naya, *ang, *seq;
|
||||
open = SCHEME_CAR(open_stack);
|
||||
open_prev = SCHEME_CDR(open);
|
||||
open = SCHEME_CAR(open);
|
||||
open_stack = SCHEME_CDR(open_stack);
|
||||
ang = honu_angles;
|
||||
if (SCHEME_STXP(SCHEME_CAR(l))) {
|
||||
Scheme_Stx *o, *c;
|
||||
int span;
|
||||
o = (Scheme_Stx *)SCHEME_CAR(open);
|
||||
c = (Scheme_Stx *)SCHEME_CAR(l);
|
||||
if ((o->srcloc->pos >= 0) && (c->srcloc->pos >= 0))
|
||||
span = (c->srcloc->pos - o->srcloc->pos) + c->srcloc->span;
|
||||
else
|
||||
span = -1;
|
||||
ang = scheme_make_stx_w_offset(ang,
|
||||
o->srcloc->line,
|
||||
o->srcloc->col,
|
||||
o->srcloc->pos,
|
||||
span,
|
||||
o->srcloc->src,
|
||||
STX_SRCTAG);
|
||||
}
|
||||
seq = scheme_make_pair(ang, SCHEME_CDR(open));
|
||||
SCHEME_CDR(prev) = scheme_null;
|
||||
if (SCHEME_STXP(ang)) {
|
||||
seq = scheme_datum_to_syntax(seq, scheme_false, ang, 0, 1);
|
||||
}
|
||||
naya = scheme_make_pair(seq, SCHEME_CDR(l));
|
||||
if (open_prev) {
|
||||
SCHEME_CDR(open_prev) = naya;
|
||||
} else {
|
||||
list = naya;
|
||||
}
|
||||
l = naya;
|
||||
} else {
|
||||
/* Not a matching close: */
|
||||
a = scheme_intern_symbol(">");
|
||||
if (SCHEME_STXP(SCHEME_CAR(l)))
|
||||
a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
|
||||
SCHEME_CAR(l) = a;
|
||||
}
|
||||
} else if (open_stack && SCHEME_SYMBOLP(a)) {
|
||||
/* Check for ids containing -, |, or &, which have lower
|
||||
operator precedence than < and >, and which therefore break up
|
||||
angle brackets. */
|
||||
for (i = SCHEME_SYM_LEN(a); i--; ) {
|
||||
ch = SCHEME_SYM_VAL(a)[i];
|
||||
if ((ch == '=') || (ch == '|') || (ch == '&')) {
|
||||
open_stack = NULL;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
prev = l;
|
||||
}
|
||||
|
||||
return list;
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
honu_add_module_wrapper(Scheme_Object *list, Scheme_Object *stxsrc, Scheme_Object *port)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -230,10 +230,23 @@ Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag)
|
|||
{
|
||||
Scheme_Object *o;
|
||||
|
||||
o = scheme_alloc_object();
|
||||
o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Cptr));
|
||||
o->type = scheme_cpointer_type;
|
||||
SCHEME_PTR1_VAL(o) = cptr;
|
||||
SCHEME_PTR2_VAL(o) = (void *)typetag;
|
||||
SCHEME_CPTR_VAL(o) = cptr;
|
||||
SCHEME_CPTR_TYPE(o) = (void *)typetag;
|
||||
|
||||
return o;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag)
|
||||
{
|
||||
Scheme_Object *o;
|
||||
|
||||
o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Offset_Cptr));
|
||||
o->type = scheme_offset_cpointer_type;
|
||||
SCHEME_CPTR_VAL(o) = cptr;
|
||||
SCHEME_CPTR_TYPE(o) = (void *)typetag;
|
||||
((Scheme_Offset_Cptr *)o)->offset = offset;
|
||||
|
||||
return o;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -335,6 +335,9 @@ MZ_EXTERN void *GC_malloc_one_tagged(size_t size_in_bytes);
|
|||
MZ_EXTERN void *GC_malloc_atomic_uncollectable(size_t size_in_bytes);
|
||||
MZ_EXTERN void *scheme_malloc_uncollectable(size_t size_in_bytes);
|
||||
MZ_EXTERN void *GC_malloc_array_tagged(size_t size_in_bytes);
|
||||
MZ_EXTERN void *GC_malloc_allow_interior(size_t size_in_bytes);
|
||||
MZ_EXTERN void *GC_malloc_atomic_allow_interior(size_t size_in_bytes);
|
||||
MZ_EXTERN void *GC_malloc_tagged_allow_interior(size_t size_in_bytes);
|
||||
# else
|
||||
MZ_EXTERN void *GC_malloc_stubborn(size_t size_in_bytes);
|
||||
MZ_EXTERN void *GC_malloc_uncollectable(size_t size_in_bytes);
|
||||
|
|
@ -524,6 +527,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o,
|
|||
XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
|
||||
|
||||
MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
|
||||
MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag);
|
||||
|
||||
MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);
|
||||
|
||||
|
|
@ -964,6 +968,11 @@ XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
|
|||
MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
|
||||
MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);
|
||||
|
||||
MZ_EXTERN void scheme_set_type_equality(Scheme_Type type,
|
||||
Scheme_Equal_Proc f,
|
||||
Scheme_Primary_Hash_Proc hash1,
|
||||
Scheme_Secondary_Hash_Proc hash2);
|
||||
|
||||
MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
|
||||
MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
|
||||
MZ_EXTERN void scheme_make_list_immutable(Scheme_Object *l);
|
||||
|
|
|
|||
|
|
@ -271,6 +271,9 @@ void *(*GC_malloc_one_tagged)(size_t size_in_bytes);
|
|||
void *(*GC_malloc_atomic_uncollectable)(size_t size_in_bytes);
|
||||
void *(*scheme_malloc_uncollectable)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_array_tagged)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_allow_interior)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_atomic_allow_interior)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_tagged_allow_interior)(size_t size_in_bytes);
|
||||
# else
|
||||
void *(*GC_malloc_stubborn)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_uncollectable)(size_t size_in_bytes);
|
||||
|
|
@ -431,6 +434,7 @@ int (*scheme_get_long_long_val)(Scheme_Object *o, mzlonglong *v);
|
|||
int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
|
||||
double (*scheme_real_to_double)(Scheme_Object *r);
|
||||
Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
|
||||
Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, long offset, Scheme_Object *typetag);
|
||||
const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
|
||||
/*========================================================================*/
|
||||
/* strings */
|
||||
|
|
@ -798,6 +802,10 @@ long (*scheme_hash_key)(Scheme_Object *o);
|
|||
#endif
|
||||
long (*scheme_equal_hash_key)(Scheme_Object *o);
|
||||
long (*scheme_equal_hash_key2)(Scheme_Object *o);
|
||||
void (*scheme_set_type_equality)(Scheme_Type type,
|
||||
Scheme_Equal_Proc f,
|
||||
Scheme_Primary_Hash_Proc hash1,
|
||||
Scheme_Secondary_Hash_Proc hash2);
|
||||
Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
|
||||
void (*scheme_make_list_immutable)(Scheme_Object *l);
|
||||
|
|
|
|||
|
|
@ -175,6 +175,9 @@
|
|||
scheme_extension_table->GC_malloc_atomic_uncollectable = GC_malloc_atomic_uncollectable;
|
||||
scheme_extension_table->scheme_malloc_uncollectable = scheme_malloc_uncollectable;
|
||||
scheme_extension_table->GC_malloc_array_tagged = GC_malloc_array_tagged;
|
||||
scheme_extension_table->GC_malloc_allow_interior = GC_malloc_allow_interior;
|
||||
scheme_extension_table->GC_malloc_atomic_allow_interior = GC_malloc_atomic_allow_interior;
|
||||
scheme_extension_table->GC_malloc_tagged_allow_interior = GC_malloc_tagged_allow_interior;
|
||||
# else
|
||||
scheme_extension_table->GC_malloc_stubborn = GC_malloc_stubborn;
|
||||
scheme_extension_table->GC_malloc_uncollectable = GC_malloc_uncollectable;
|
||||
|
|
@ -296,6 +299,7 @@
|
|||
scheme_extension_table->scheme_get_unsigned_long_long_val = scheme_get_unsigned_long_long_val;
|
||||
scheme_extension_table->scheme_real_to_double = scheme_real_to_double;
|
||||
scheme_extension_table->scheme_make_cptr = scheme_make_cptr;
|
||||
scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr;
|
||||
scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name;
|
||||
scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
|
||||
scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix;
|
||||
|
|
@ -539,6 +543,7 @@
|
|||
#endif
|
||||
scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key;
|
||||
scheme_extension_table->scheme_equal_hash_key2 = scheme_equal_hash_key2;
|
||||
scheme_extension_table->scheme_set_type_equality = scheme_set_type_equality;
|
||||
scheme_extension_table->scheme_build_list = scheme_build_list;
|
||||
scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
|
||||
scheme_extension_table->scheme_make_list_immutable = scheme_make_list_immutable;
|
||||
|
|
|
|||
|
|
@ -175,6 +175,9 @@
|
|||
#define GC_malloc_atomic_uncollectable (scheme_extension_table->GC_malloc_atomic_uncollectable)
|
||||
#define scheme_malloc_uncollectable (scheme_extension_table->scheme_malloc_uncollectable)
|
||||
#define GC_malloc_array_tagged (scheme_extension_table->GC_malloc_array_tagged)
|
||||
#define GC_malloc_allow_interior (scheme_extension_table->GC_malloc_allow_interior)
|
||||
#define GC_malloc_atomic_allow_interior (scheme_extension_table->GC_malloc_atomic_allow_interior)
|
||||
#define GC_malloc_tagged_allow_interior (scheme_extension_table->GC_malloc_tagged_allow_interior)
|
||||
# else
|
||||
#define GC_malloc_stubborn (scheme_extension_table->GC_malloc_stubborn)
|
||||
#define GC_malloc_uncollectable (scheme_extension_table->GC_malloc_uncollectable)
|
||||
|
|
@ -296,6 +299,7 @@
|
|||
#define scheme_get_unsigned_long_long_val (scheme_extension_table->scheme_get_unsigned_long_long_val)
|
||||
#define scheme_real_to_double (scheme_extension_table->scheme_real_to_double)
|
||||
#define scheme_make_cptr (scheme_extension_table->scheme_make_cptr)
|
||||
#define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
|
||||
#define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
|
||||
#define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
|
||||
#define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix)
|
||||
|
|
@ -539,6 +543,7 @@
|
|||
#endif
|
||||
#define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key)
|
||||
#define scheme_equal_hash_key2 (scheme_extension_table->scheme_equal_hash_key2)
|
||||
#define scheme_set_type_equality (scheme_extension_table->scheme_set_type_equality)
|
||||
#define scheme_build_list (scheme_extension_table->scheme_build_list)
|
||||
#define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
|
||||
#define scheme_make_list_immutable (scheme_extension_table->scheme_make_list_immutable)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 890
|
||||
#define EXPECTED_PRIM_COUNT 891
|
||||
|
||||
#ifdef MZSCHEME_SOMETHING_OMITTED
|
||||
# undef USE_COMPILED_STARTUP
|
||||
|
|
|
|||
|
|
@ -201,6 +201,10 @@ typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj);
|
|||
extern Scheme_Type_Reader *scheme_type_readers;
|
||||
extern Scheme_Type_Writer *scheme_type_writers;
|
||||
|
||||
extern Scheme_Equal_Proc *scheme_type_equals;
|
||||
extern Scheme_Primary_Hash_Proc *scheme_type_hash1s;
|
||||
extern Scheme_Secondary_Hash_Proc *scheme_type_hash2s;
|
||||
|
||||
void scheme_init_port_config(void);
|
||||
void scheme_init_port_fun_config(void);
|
||||
Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *c);
|
||||
|
|
@ -607,6 +611,8 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
|
|||
Scheme_Object *old,
|
||||
Scheme_Object *origin);
|
||||
|
||||
int scheme_stx_has_empty_wraps(Scheme_Object *);
|
||||
|
||||
Scheme_Object *scheme_new_mark(void);
|
||||
Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m);
|
||||
|
||||
|
|
@ -2708,6 +2714,8 @@ Scheme_Object *scheme_checked_caar(int argc, Scheme_Object **argv);
|
|||
Scheme_Object *scheme_checked_cadr(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_checked_cdar(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_checked_cddr(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_checked_set_car (int argc, Scheme_Object *argv[]);
|
||||
Scheme_Object *scheme_checked_set_cdr (int argc, Scheme_Object *argv[]);
|
||||
Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]);
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@
|
|||
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR 369
|
||||
#define MZSCHEME_VERSION_MINOR 7
|
||||
#define MZSCHEME_VERSION_MINOR 8
|
||||
|
||||
#define MZSCHEME_VERSION "369.7" _MZ_SPECIAL_TAG
|
||||
#define MZSCHEME_VERSION "369.8" _MZ_SPECIAL_TAG
|
||||
|
|
|
|||
|
|
@ -3564,6 +3564,7 @@
|
|||
"(require #%qqstx)"
|
||||
"(require #%define)"
|
||||
"(require #%expobs) "
|
||||
"(require(only #%foreign)) "
|
||||
"(provide(all-from #%more-scheme)"
|
||||
"(all-from-except #%misc make-standard-module-name-resolver)"
|
||||
"(all-from-except #%stxcase-scheme -define -define-syntax)"
|
||||
|
|
|
|||
|
|
@ -4072,6 +4072,7 @@
|
|||
(require #%qqstx)
|
||||
(require #%define)
|
||||
(require #%expobs) ; so it's attached
|
||||
(require (only #%foreign)) ; so it's attached, but doesn't depend on any exports
|
||||
|
||||
(provide (all-from #%more-scheme)
|
||||
(all-from-except #%misc make-standard-module-name-resolver)
|
||||
|
|
|
|||
|
|
@ -2494,6 +2494,11 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
|
|||
return lift_inactive_certs(o, 1);
|
||||
}
|
||||
|
||||
int scheme_stx_has_empty_wraps(Scheme_Object *o)
|
||||
{
|
||||
return SCHEME_NULLP(((Scheme_Stx *)o)->wraps);
|
||||
}
|
||||
|
||||
/*========================================================================*/
|
||||
/* stx comparison */
|
||||
/*========================================================================*/
|
||||
|
|
@ -2682,6 +2687,14 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
|
|||
|
||||
#define QUICK_STACK_SIZE 10
|
||||
|
||||
#define EXPLAIN_RESOLVE 0
|
||||
#if EXPLAIN_RESOLVE
|
||||
static int explain_resolves = 0;
|
||||
# define EXPLAIN(x) if (explain_resolves) { x; }
|
||||
#else
|
||||
# define EXPLAIN(x) /* empty */
|
||||
#endif
|
||||
|
||||
/* Although resolve_env may call itself recursively, the recursion
|
||||
depth is bounded (by the fact that modules can't be nested,
|
||||
etc.). */
|
||||
|
|
@ -2710,6 +2723,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
Scheme_Object *bdg = NULL;
|
||||
Scheme_Hash_Table *export_registry = NULL;
|
||||
|
||||
EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a))));
|
||||
|
||||
if (_wraps) {
|
||||
WRAP_POS_COPY(wraps, *_wraps);
|
||||
WRAP_POS_INC(wraps);
|
||||
|
|
@ -2722,27 +2737,37 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
Scheme_Object *result, *key;
|
||||
int did_lexical = 0;
|
||||
|
||||
EXPLAIN(printf("Rename...\n"));
|
||||
|
||||
result = scheme_false;
|
||||
while (!SCHEME_NULLP(o_rename_stack)) {
|
||||
key = SCHEME_CAAR(o_rename_stack);
|
||||
if (SAME_OBJ(key, result)) {
|
||||
EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0)));
|
||||
did_lexical = 1;
|
||||
result = SCHEME_CDR(SCHEME_CAR(o_rename_stack));
|
||||
} else if (SAME_OBJ(key, scheme_true)) {
|
||||
/* marks a module-level renaming that overrides lexical renaming */
|
||||
did_lexical = 0;
|
||||
}
|
||||
} else {
|
||||
EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0)));
|
||||
if (SAME_OBJ(key, scheme_true)) {
|
||||
/* marks a module-level renaming that overrides lexical renaming */
|
||||
did_lexical = 0;
|
||||
}
|
||||
}
|
||||
o_rename_stack = SCHEME_CDR(o_rename_stack);
|
||||
}
|
||||
while (stack_pos) {
|
||||
key = rename_stack[stack_pos - 1];
|
||||
if (SAME_OBJ(key, result)) {
|
||||
EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0)));
|
||||
result = rename_stack[stack_pos - 2];
|
||||
did_lexical = 1;
|
||||
} else if (SAME_OBJ(key, scheme_true)) {
|
||||
/* marks a module-level renaming that overrides lexical renaming */
|
||||
did_lexical = 0;
|
||||
}
|
||||
} else {
|
||||
EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0)));
|
||||
if (SAME_OBJ(key, scheme_true)) {
|
||||
/* marks a module-level renaming that overrides lexical renaming */
|
||||
did_lexical = 0;
|
||||
}
|
||||
}
|
||||
stack_pos -= 2;
|
||||
}
|
||||
if (!did_lexical)
|
||||
|
|
@ -2750,6 +2775,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
else if (get_names)
|
||||
get_names[0] = scheme_undefined;
|
||||
|
||||
EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0)));
|
||||
|
||||
return result;
|
||||
} else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) && w_mod) {
|
||||
/* Module rename: */
|
||||
|
|
@ -2934,6 +2961,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
other_env = scheme_false;
|
||||
envname = SCHEME_VEC_ELS(rename)[2+c+ri];
|
||||
same = 1;
|
||||
EXPLAIN(printf("Targes %s <- %s\n",
|
||||
scheme_write_to_string(envname, 0),
|
||||
scheme_write_to_string(other_env, 0)));
|
||||
} else {
|
||||
envname = SCHEME_VEC_ELS(rename)[0];
|
||||
other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
|
||||
|
|
@ -2946,10 +2976,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
SCHEME_USE_FUEL(1);
|
||||
}
|
||||
|
||||
EXPLAIN(printf("Target %s <- %s (%d)\n",
|
||||
scheme_write_to_string(envname, 0),
|
||||
scheme_write_to_string(other_env, 0),
|
||||
SCHEME_IMMUTABLEP(rename)));
|
||||
|
||||
{
|
||||
WRAP_POS w2;
|
||||
WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
|
||||
same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
|
||||
if (!same)
|
||||
EXPLAIN(printf("Different marks\n"));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -2977,14 +3014,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
} else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) {
|
||||
/* Lexical-rename rib. Splice in the names. */
|
||||
rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
|
||||
EXPLAIN(printf("Rib: %p...\n", rib));
|
||||
if (skip_ribs) {
|
||||
if (scheme_bin_gt_eq(rib->timestamp, skip_ribs))
|
||||
if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) {
|
||||
EXPLAIN(printf("Skip rib\n"));
|
||||
rib = NULL;
|
||||
}
|
||||
}
|
||||
if (rib) {
|
||||
if (SAME_OBJ(did_rib, rib))
|
||||
if (SAME_OBJ(did_rib, rib)) {
|
||||
EXPLAIN(printf("Did rib\n"));
|
||||
rib = NULL;
|
||||
else {
|
||||
} else {
|
||||
did_rib = rib;
|
||||
rib = rib->next; /* First rib record has no rename */
|
||||
}
|
||||
|
|
@ -3271,6 +3312,16 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, long phase)
|
|||
return scheme_stx_env_bound_eq(a, b, NULL, phase);
|
||||
}
|
||||
|
||||
#if EXPLAIN
|
||||
Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
|
||||
{
|
||||
explain_resolves++;
|
||||
a = resolve_env(NULL, a, 0, 0, NULL, NULL);
|
||||
--explain_resolves;
|
||||
return a;
|
||||
}
|
||||
#endif
|
||||
|
||||
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
|
||||
{
|
||||
/* Inspect the wraps to look for a self-modidx shift: */
|
||||
|
|
|
|||
|
|
@ -84,150 +84,152 @@ enum {
|
|||
scheme_sema_type, /* 66 */
|
||||
scheme_hash_table_type, /* 67 */
|
||||
scheme_cpointer_type, /* 68 */
|
||||
scheme_weak_box_type, /* 69 */
|
||||
scheme_ephemeron_type, /* 70 */
|
||||
scheme_struct_type_type, /* 71 */
|
||||
scheme_module_index_type, /* 72 */
|
||||
scheme_set_macro_type, /* 73 */
|
||||
scheme_listener_type, /* 74 */
|
||||
scheme_namespace_type, /* 75 */
|
||||
scheme_config_type, /* 76 */
|
||||
scheme_stx_type, /* 77 */
|
||||
scheme_will_executor_type, /* 78 */
|
||||
scheme_custodian_type, /* 79 */
|
||||
scheme_random_state_type, /* 80 */
|
||||
scheme_regexp_type, /* 81 */
|
||||
scheme_bucket_type, /* 82 */
|
||||
scheme_bucket_table_type, /* 83 */
|
||||
scheme_subprocess_type, /* 84 */
|
||||
scheme_compilation_top_type, /* 85 */
|
||||
scheme_wrap_chunk_type, /* 86 */
|
||||
scheme_eval_waiting_type, /* 87 */
|
||||
scheme_tail_call_waiting_type, /* 88 */
|
||||
scheme_undefined_type, /* 89 */
|
||||
scheme_struct_property_type, /* 90 */
|
||||
scheme_multiple_values_type, /* 91 */
|
||||
scheme_placeholder_type, /* 92 */
|
||||
scheme_case_lambda_sequence_type, /* 93 */
|
||||
scheme_begin0_sequence_type, /* 94 */
|
||||
scheme_rename_table_type, /* 95 */
|
||||
scheme_module_type, /* 96 */
|
||||
scheme_svector_type, /* 97 */
|
||||
scheme_lazy_macro_type, /* 98 */
|
||||
scheme_resolve_prefix_type, /* 99 */
|
||||
scheme_security_guard_type, /* 100 */
|
||||
scheme_indent_type, /* 101 */
|
||||
scheme_udp_type, /* 102 */
|
||||
scheme_udp_evt_type, /* 103 */
|
||||
scheme_tcp_accept_evt_type, /* 104 */
|
||||
scheme_id_macro_type, /* 105 */
|
||||
scheme_evt_set_type, /* 106 */
|
||||
scheme_wrap_evt_type, /* 107 */
|
||||
scheme_handle_evt_type, /* 108 */
|
||||
scheme_nack_guard_evt_type, /* 109 */
|
||||
scheme_semaphore_repost_type, /* 110 */
|
||||
scheme_channel_type, /* 111 */
|
||||
scheme_channel_put_type, /* 112 */
|
||||
scheme_thread_resume_type, /* 113 */
|
||||
scheme_thread_suspend_type, /* 114 */
|
||||
scheme_thread_dead_type, /* 115 */
|
||||
scheme_poll_evt_type, /* 116 */
|
||||
scheme_nack_evt_type, /* 117 */
|
||||
scheme_module_registry_type, /* 118 */
|
||||
scheme_thread_set_type, /* 119 */
|
||||
scheme_string_converter_type, /* 120 */
|
||||
scheme_alarm_type, /* 121 */
|
||||
scheme_thread_cell_type, /* 122 */
|
||||
scheme_channel_syncer_type, /* 123 */
|
||||
scheme_special_comment_type, /* 124 */
|
||||
scheme_write_evt_type, /* 125 */
|
||||
scheme_always_evt_type, /* 126 */
|
||||
scheme_never_evt_type, /* 127 */
|
||||
scheme_progress_evt_type, /* 128 */
|
||||
scheme_certifications_type, /* 129 */
|
||||
scheme_already_comp_type, /* 130 */
|
||||
scheme_readtable_type, /* 131 */
|
||||
scheme_intdef_context_type, /* 132 */
|
||||
scheme_lexical_rib_type, /* 133 */
|
||||
scheme_thread_cell_values_type, /* 134 */
|
||||
scheme_global_ref_type, /* 135 */
|
||||
scheme_cont_mark_chain_type, /* 136 */
|
||||
scheme_raw_pair_type, /* 137 */
|
||||
scheme_prompt_type, /* 138 */
|
||||
scheme_prompt_tag_type, /* 139 */
|
||||
scheme_delay_syntax_type, /* 140 */
|
||||
scheme_offset_cpointer_type, /* 69 */
|
||||
scheme_weak_box_type, /* 70 */
|
||||
scheme_ephemeron_type, /* 71 */
|
||||
scheme_struct_type_type, /* 72 */
|
||||
scheme_module_index_type, /* 73 */
|
||||
scheme_set_macro_type, /* 74 */
|
||||
scheme_listener_type, /* 75 */
|
||||
scheme_namespace_type, /* 76 */
|
||||
scheme_config_type, /* 77 */
|
||||
scheme_stx_type, /* 78 */
|
||||
scheme_will_executor_type, /* 79 */
|
||||
scheme_custodian_type, /* 80 */
|
||||
scheme_random_state_type, /* 81 */
|
||||
scheme_regexp_type, /* 82 */
|
||||
scheme_bucket_type, /* 83 */
|
||||
scheme_bucket_table_type, /* 84 */
|
||||
scheme_subprocess_type, /* 85 */
|
||||
scheme_compilation_top_type, /* 86 */
|
||||
scheme_wrap_chunk_type, /* 87 */
|
||||
scheme_eval_waiting_type, /* 88 */
|
||||
scheme_tail_call_waiting_type, /* 89 */
|
||||
scheme_undefined_type, /* 90 */
|
||||
scheme_struct_property_type, /* 91 */
|
||||
scheme_multiple_values_type, /* 92 */
|
||||
scheme_placeholder_type, /* 93 */
|
||||
scheme_case_lambda_sequence_type, /* 94 */
|
||||
scheme_begin0_sequence_type, /* 95 */
|
||||
scheme_rename_table_type, /* 96 */
|
||||
scheme_module_type, /* 97 */
|
||||
scheme_svector_type, /* 98 */
|
||||
scheme_lazy_macro_type, /* 99 */
|
||||
scheme_resolve_prefix_type, /* 100 */
|
||||
scheme_security_guard_type, /* 101 */
|
||||
scheme_indent_type, /* 102 */
|
||||
scheme_udp_type, /* 103 */
|
||||
scheme_udp_evt_type, /* 104 */
|
||||
scheme_tcp_accept_evt_type, /* 105 */
|
||||
scheme_id_macro_type, /* 106 */
|
||||
scheme_evt_set_type, /* 107 */
|
||||
scheme_wrap_evt_type, /* 108 */
|
||||
scheme_handle_evt_type, /* 109 */
|
||||
scheme_nack_guard_evt_type, /* 110 */
|
||||
scheme_semaphore_repost_type, /* 111 */
|
||||
scheme_channel_type, /* 112 */
|
||||
scheme_channel_put_type, /* 113 */
|
||||
scheme_thread_resume_type, /* 114 */
|
||||
scheme_thread_suspend_type, /* 115 */
|
||||
scheme_thread_dead_type, /* 116 */
|
||||
scheme_poll_evt_type, /* 117 */
|
||||
scheme_nack_evt_type, /* 118 */
|
||||
scheme_module_registry_type, /* 119 */
|
||||
scheme_thread_set_type, /* 120 */
|
||||
scheme_string_converter_type, /* 121 */
|
||||
scheme_alarm_type, /* 122 */
|
||||
scheme_thread_cell_type, /* 123 */
|
||||
scheme_channel_syncer_type, /* 124 */
|
||||
scheme_special_comment_type, /* 125 */
|
||||
scheme_write_evt_type, /* 126 */
|
||||
scheme_always_evt_type, /* 127 */
|
||||
scheme_never_evt_type, /* 128 */
|
||||
scheme_progress_evt_type, /* 129 */
|
||||
scheme_certifications_type, /* 130 */
|
||||
scheme_already_comp_type, /* 131 */
|
||||
scheme_readtable_type, /* 132 */
|
||||
scheme_intdef_context_type, /* 133 */
|
||||
scheme_lexical_rib_type, /* 134 */
|
||||
scheme_thread_cell_values_type, /* 135 */
|
||||
scheme_global_ref_type, /* 136 */
|
||||
scheme_cont_mark_chain_type, /* 137 */
|
||||
scheme_raw_pair_type, /* 138 */
|
||||
scheme_prompt_type, /* 139 */
|
||||
scheme_prompt_tag_type, /* 140 */
|
||||
scheme_expanded_syntax_type, /* 141 */
|
||||
scheme_delay_syntax_type, /* 142 */
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_, /* 141 */
|
||||
_scheme_last_normal_type_, /* 143 */
|
||||
|
||||
scheme_rt_weak_array, /* 142 */
|
||||
scheme_rt_weak_array, /* 144 */
|
||||
|
||||
scheme_rt_comp_env, /* 143 */
|
||||
scheme_rt_constant_binding, /* 144 */
|
||||
scheme_rt_resolve_info, /* 145 */
|
||||
scheme_rt_optimize_info, /* 146 */
|
||||
scheme_rt_compile_info, /* 147 */
|
||||
scheme_rt_cont_mark, /* 148 */
|
||||
scheme_rt_saved_stack, /* 149 */
|
||||
scheme_rt_reply_item, /* 150 */
|
||||
scheme_rt_closure_info, /* 151 */
|
||||
scheme_rt_overflow, /* 152 */
|
||||
scheme_rt_overflow_jmp, /* 153 */
|
||||
scheme_rt_meta_cont, /* 154 */
|
||||
scheme_rt_dyn_wind_cell, /* 155 */
|
||||
scheme_rt_dyn_wind_info, /* 156 */
|
||||
scheme_rt_dyn_wind, /* 157 */
|
||||
scheme_rt_dup_check, /* 158 */
|
||||
scheme_rt_thread_memory, /* 159 */
|
||||
scheme_rt_input_file, /* 160 */
|
||||
scheme_rt_input_fd, /* 161 */
|
||||
scheme_rt_oskit_console_input, /* 162 */
|
||||
scheme_rt_tested_input_file, /* 163 */
|
||||
scheme_rt_tested_output_file, /* 164 */
|
||||
scheme_rt_indexed_string, /* 165 */
|
||||
scheme_rt_output_file, /* 166 */
|
||||
scheme_rt_load_handler_data, /* 167 */
|
||||
scheme_rt_pipe, /* 168 */
|
||||
scheme_rt_beos_process, /* 169 */
|
||||
scheme_rt_system_child, /* 170 */
|
||||
scheme_rt_tcp, /* 171 */
|
||||
scheme_rt_write_data, /* 172 */
|
||||
scheme_rt_tcp_select_info, /* 173 */
|
||||
scheme_rt_namespace_option, /* 174 */
|
||||
scheme_rt_param_data, /* 175 */
|
||||
scheme_rt_will, /* 176 */
|
||||
scheme_rt_will_registration, /* 177 */
|
||||
scheme_rt_struct_proc_info, /* 178 */
|
||||
scheme_rt_linker_name, /* 179 */
|
||||
scheme_rt_param_map, /* 180 */
|
||||
scheme_rt_finalization, /* 181 */
|
||||
scheme_rt_finalizations, /* 182 */
|
||||
scheme_rt_cpp_object, /* 183 */
|
||||
scheme_rt_cpp_array_object, /* 184 */
|
||||
scheme_rt_stack_object, /* 185 */
|
||||
scheme_rt_preallocated_object, /* 186 */
|
||||
scheme_thread_hop_type, /* 187 */
|
||||
scheme_rt_srcloc, /* 188 */
|
||||
scheme_rt_evt, /* 189 */
|
||||
scheme_rt_syncing, /* 190 */
|
||||
scheme_rt_comp_prefix, /* 191 */
|
||||
scheme_rt_user_input, /* 192 */
|
||||
scheme_rt_user_output, /* 193 */
|
||||
scheme_rt_compact_port, /* 194 */
|
||||
scheme_rt_read_special_dw, /* 195 */
|
||||
scheme_rt_regwork, /* 196 */
|
||||
scheme_rt_buf_holder, /* 197 */
|
||||
scheme_rt_parameterization, /* 198 */
|
||||
scheme_rt_print_params, /* 199 */
|
||||
scheme_rt_read_params, /* 200 */
|
||||
scheme_rt_native_code, /* 201 */
|
||||
scheme_rt_native_code_plus_case, /* 202 */
|
||||
scheme_rt_jitter_data, /* 203 */
|
||||
scheme_rt_module_exports, /* 204 */
|
||||
scheme_rt_delay_load_info, /* 205 */
|
||||
scheme_rt_marshal_info, /* 206 */
|
||||
scheme_rt_unmarshal_info, /* 207 */
|
||||
scheme_rt_runstack, /* 208 */
|
||||
scheme_rt_comp_env, /* 145 */
|
||||
scheme_rt_constant_binding, /* 146 */
|
||||
scheme_rt_resolve_info, /* 147 */
|
||||
scheme_rt_optimize_info, /* 148 */
|
||||
scheme_rt_compile_info, /* 149 */
|
||||
scheme_rt_cont_mark, /* 150 */
|
||||
scheme_rt_saved_stack, /* 151 */
|
||||
scheme_rt_reply_item, /* 152 */
|
||||
scheme_rt_closure_info, /* 153 */
|
||||
scheme_rt_overflow, /* 154 */
|
||||
scheme_rt_overflow_jmp, /* 155 */
|
||||
scheme_rt_meta_cont, /* 156 */
|
||||
scheme_rt_dyn_wind_cell, /* 157 */
|
||||
scheme_rt_dyn_wind_info, /* 158 */
|
||||
scheme_rt_dyn_wind, /* 159 */
|
||||
scheme_rt_dup_check, /* 160 */
|
||||
scheme_rt_thread_memory, /* 161 */
|
||||
scheme_rt_input_file, /* 162 */
|
||||
scheme_rt_input_fd, /* 163 */
|
||||
scheme_rt_oskit_console_input, /* 164 */
|
||||
scheme_rt_tested_input_file, /* 165 */
|
||||
scheme_rt_tested_output_file, /* 166 */
|
||||
scheme_rt_indexed_string, /* 167 */
|
||||
scheme_rt_output_file, /* 168 */
|
||||
scheme_rt_load_handler_data, /* 169 */
|
||||
scheme_rt_pipe, /* 170 */
|
||||
scheme_rt_beos_process, /* 171 */
|
||||
scheme_rt_system_child, /* 172 */
|
||||
scheme_rt_tcp, /* 173 */
|
||||
scheme_rt_write_data, /* 174 */
|
||||
scheme_rt_tcp_select_info, /* 175 */
|
||||
scheme_rt_namespace_option, /* 176 */
|
||||
scheme_rt_param_data, /* 177 */
|
||||
scheme_rt_will, /* 178 */
|
||||
scheme_rt_will_registration, /* 179 */
|
||||
scheme_rt_struct_proc_info, /* 180 */
|
||||
scheme_rt_linker_name, /* 181 */
|
||||
scheme_rt_param_map, /* 182 */
|
||||
scheme_rt_finalization, /* 183 */
|
||||
scheme_rt_finalizations, /* 184 */
|
||||
scheme_rt_cpp_object, /* 185 */
|
||||
scheme_rt_cpp_array_object, /* 186 */
|
||||
scheme_rt_stack_object, /* 187 */
|
||||
scheme_rt_preallocated_object, /* 188 */
|
||||
scheme_thread_hop_type, /* 189 */
|
||||
scheme_rt_srcloc, /* 190 */
|
||||
scheme_rt_evt, /* 191 */
|
||||
scheme_rt_syncing, /* 192 */
|
||||
scheme_rt_comp_prefix, /* 193 */
|
||||
scheme_rt_user_input, /* 194 */
|
||||
scheme_rt_user_output, /* 195 */
|
||||
scheme_rt_compact_port, /* 196 */
|
||||
scheme_rt_read_special_dw, /* 197 */
|
||||
scheme_rt_regwork, /* 198 */
|
||||
scheme_rt_buf_holder, /* 199 */
|
||||
scheme_rt_parameterization, /* 200 */
|
||||
scheme_rt_print_params, /* 201 */
|
||||
scheme_rt_read_params, /* 202 */
|
||||
scheme_rt_native_code, /* 203 */
|
||||
scheme_rt_native_code_plus_case, /* 204 */
|
||||
scheme_rt_jitter_data, /* 205 */
|
||||
scheme_rt_module_exports, /* 206 */
|
||||
scheme_rt_delay_load_info, /* 207 */
|
||||
scheme_rt_marshal_info, /* 208 */
|
||||
scheme_rt_unmarshal_info, /* 209 */
|
||||
scheme_rt_runstack, /* 210 */
|
||||
#endif
|
||||
|
||||
_scheme_last_type_
|
||||
|
|
|
|||
|
|
@ -4396,6 +4396,7 @@ static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_onl
|
|||
static Scheme_Object *
|
||||
single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
|
||||
{
|
||||
scheme_rec_add_certs(rec, drec, form);
|
||||
return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec);
|
||||
}
|
||||
|
||||
|
|
@ -4405,15 +4406,20 @@ single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
|
|||
{
|
||||
Scheme_Object *expr, *form_name;
|
||||
|
||||
scheme_rec_add_certs(erec, drec, form);
|
||||
|
||||
expr = check_single(form, top_only ? env : NULL);
|
||||
expr = scheme_expand_expr(expr, env, erec, drec);
|
||||
|
||||
form_name = SCHEME_STX_CAR(form);
|
||||
|
||||
if (simplify && (erec[drec].depth == -1)) {
|
||||
/* FIXME: this needs EXPAND_OBSERVE callbacks. */
|
||||
expr = scheme_stx_track(expr, form, form_name);
|
||||
expr = scheme_stx_cert(expr, scheme_false, NULL, form, NULL, 1);
|
||||
return expr;
|
||||
}
|
||||
|
||||
form_name = SCHEME_STX_CAR(form);
|
||||
|
||||
return scheme_datum_to_syntax(icons(form_name, icons(expr, scheme_null)),
|
||||
form, form,
|
||||
0, 2);
|
||||
|
|
|
|||
|
|
@ -6755,8 +6755,13 @@ static void prepare_thread_for_GC(Scheme_Object *t)
|
|||
}
|
||||
}
|
||||
|
||||
if (p->values_buffer)
|
||||
memset(p->values_buffer, 0, sizeof(Scheme_Object*) * p->values_buffer_size);
|
||||
if (p->values_buffer) {
|
||||
if (p->values_buffer_size > 128)
|
||||
p->values_buffer = NULL;
|
||||
else {
|
||||
memset(p->values_buffer, 0, sizeof(Scheme_Object*) * p->values_buffer_size);
|
||||
}
|
||||
}
|
||||
|
||||
p->spare_runstack = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,9 @@
|
|||
|
||||
Scheme_Type_Reader *scheme_type_readers;
|
||||
Scheme_Type_Writer *scheme_type_writers;
|
||||
Scheme_Equal_Proc *scheme_type_equals;
|
||||
Scheme_Primary_Hash_Proc *scheme_type_hash1s;
|
||||
Scheme_Secondary_Hash_Proc *scheme_type_hash2s;
|
||||
|
||||
static char **type_names;
|
||||
static Scheme_Type maxtype, allocmax;
|
||||
|
|
@ -42,6 +45,9 @@ static void init_type_arrays()
|
|||
REGISTER_SO(type_names);
|
||||
REGISTER_SO(scheme_type_readers);
|
||||
REGISTER_SO(scheme_type_writers);
|
||||
REGISTER_SO(scheme_type_equals);
|
||||
REGISTER_SO(scheme_type_hash1s);
|
||||
REGISTER_SO(scheme_type_hash2s);
|
||||
|
||||
maxtype = _scheme_last_type_;
|
||||
allocmax = maxtype + 10;
|
||||
|
|
@ -63,6 +69,18 @@ static void init_type_arrays()
|
|||
#ifdef MEMORY_COUNTING_ON
|
||||
scheme_type_table_count += n;
|
||||
#endif
|
||||
|
||||
scheme_type_equals = MALLOC_N_ATOMIC(Scheme_Equal_Proc, allocmax);
|
||||
n = allocmax * sizeof(Scheme_Equal_Proc);
|
||||
memset((char *)scheme_type_equals, 0, n);
|
||||
|
||||
scheme_type_hash1s = MALLOC_N_ATOMIC(Scheme_Primary_Hash_Proc, allocmax);
|
||||
n = allocmax * sizeof(Scheme_Primary_Hash_Proc);
|
||||
memset((char *)scheme_type_hash1s, 0, n);
|
||||
|
||||
scheme_type_hash2s = MALLOC_N_ATOMIC(Scheme_Secondary_Hash_Proc, allocmax);
|
||||
n = allocmax * sizeof(Scheme_Secondary_Hash_Proc);
|
||||
memset((char *)scheme_type_hash2s, 0, n);
|
||||
}
|
||||
|
||||
void
|
||||
|
|
@ -183,6 +201,7 @@ scheme_init_type (Scheme_Env *env)
|
|||
|
||||
set_name(scheme_stx_type, "<syntax>");
|
||||
set_name(scheme_stx_offset_type, "<internal-syntax-offset>");
|
||||
set_name(scheme_expanded_syntax_type, "<expanded-syntax>");
|
||||
set_name(scheme_set_macro_type, "<set!-transformer>");
|
||||
set_name(scheme_id_macro_type, "<rename-transformer>");
|
||||
|
||||
|
|
@ -192,6 +211,7 @@ scheme_init_type (Scheme_Env *env)
|
|||
set_name(scheme_subprocess_type, "<subprocess>");
|
||||
|
||||
set_name(scheme_cpointer_type, "<cpointer>");
|
||||
set_name(scheme_offset_cpointer_type, "<cpointer>");
|
||||
|
||||
set_name(scheme_wrap_chunk_type, "<wrap-chunk>");
|
||||
|
||||
|
|
@ -270,10 +290,25 @@ Scheme_Type scheme_make_type(const char *name)
|
|||
memcpy(naya, scheme_type_writers, maxtype * sizeof(Scheme_Type_Writer));
|
||||
scheme_type_writers = (Scheme_Type_Writer *)naya;
|
||||
|
||||
naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Equal_Proc));
|
||||
memset((char *)naya, 0, n);
|
||||
memcpy(naya, scheme_type_equals, maxtype * sizeof(Scheme_Equal_Proc));
|
||||
scheme_type_equals = (Scheme_Equal_Proc *)naya;
|
||||
|
||||
naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Primary_Hash_Proc));
|
||||
memset((char *)naya, 0, n);
|
||||
memcpy(naya, scheme_type_hash1s, maxtype * sizeof(Scheme_Primary_Hash_Proc));
|
||||
scheme_type_hash1s = (Scheme_Primary_Hash_Proc *)naya;
|
||||
|
||||
naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Secondary_Hash_Proc));
|
||||
memset((char *)naya, 0, n);
|
||||
memcpy(naya, scheme_type_hash2s, maxtype * sizeof(Scheme_Secondary_Hash_Proc));
|
||||
scheme_type_hash2s = (Scheme_Secondary_Hash_Proc *)naya;
|
||||
|
||||
#ifdef MEMORY_COUNTING_ON
|
||||
scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader)
|
||||
+ sizeof(Scheme_Type_Writer));
|
||||
scheme_misc_count += (20 * sizeof(char *));
|
||||
scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader)
|
||||
+ sizeof(Scheme_Type_Writer));
|
||||
scheme_misc_count += (20 * sizeof(char *));
|
||||
#endif
|
||||
}
|
||||
|
||||
|
|
@ -309,6 +344,20 @@ void scheme_install_type_writer(Scheme_Type t, Scheme_Type_Writer f)
|
|||
scheme_type_writers[t] = f;
|
||||
}
|
||||
|
||||
|
||||
void scheme_set_type_equality(Scheme_Type t,
|
||||
Scheme_Equal_Proc f,
|
||||
Scheme_Primary_Hash_Proc hash1,
|
||||
Scheme_Secondary_Hash_Proc hash2)
|
||||
{
|
||||
if (t < 0 || t >= maxtype)
|
||||
return;
|
||||
|
||||
scheme_type_equals[t] = f;
|
||||
scheme_type_hash1s[t] = hash1;
|
||||
scheme_type_hash2s[t] = hash2;
|
||||
}
|
||||
|
||||
int scheme_num_types(void)
|
||||
{
|
||||
return maxtype;
|
||||
|
|
@ -464,6 +513,7 @@ void scheme_register_traversers(void)
|
|||
GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
|
||||
GC_REG_TRAV(scheme_vector_type, vector_obj);
|
||||
GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);
|
||||
GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj);
|
||||
|
||||
GC_REG_TRAV(scheme_bucket_type, bucket_obj);
|
||||
|
||||
|
|
@ -512,6 +562,7 @@ void scheme_register_traversers(void)
|
|||
|
||||
GC_REG_TRAV(scheme_stx_type, stx_val);
|
||||
GC_REG_TRAV(scheme_stx_offset_type, stx_off_val);
|
||||
GC_REG_TRAV(scheme_expanded_syntax_type, twoptr_obj);
|
||||
GC_REG_TRAV(scheme_module_type, module_val);
|
||||
GC_REG_TRAV(scheme_rt_module_exports, module_exports_val);
|
||||
GC_REG_TRAV(scheme_module_index_type, modidx_val);
|
||||
|
|
|
|||
|
|
@ -1659,6 +1659,7 @@ void wxPostScriptDC::StartPage (void)
|
|||
pstream->Out("%%EndPageSetup\n");
|
||||
|
||||
resetFont = RESET_FONT | RESET_COLOR;
|
||||
current_font_name = NULL;
|
||||
|
||||
if (clipping)
|
||||
SetClippingRegion(clipping);
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user