<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
\r
<erg> if write returns -1 and errno == EINTR then it's not a real error, you can try again\r
-\r
-- make head? tail? more efficient with slices\r
-- fix ceiling\r
- single-stepper and variable access: wrong namespace?\r
- investigate if COPYING_GEN needs a fix\r
- faster layout\r
-- keep alive\r
+- http keep alive, and range get\r
- sleep word\r
-- fix fixnum<< overflow on PowerPC\r
- fix i/o on generic x86/ppc unix\r
- alien primitives need a more general input type\r
- 2map slow with lists\r
\r
+ compiler:\r
\r
+- powerpc: float ffi parameters\r
+- fix fixnum<< and /i overflow on PowerPC\r
- simplifier:\r
- kill replace after a peek\r
- merge inc-d's across VOPs that don't touch the stack\r
\subsubsection{Quotation variants}
-There are three words that combine shuffle words with \texttt{call}. They are useful in the implementation of higher-order words taking quotations as inputs.
+There are some words that combine shuffle words with \texttt{call}. They are useful in the implementation of higher-order words taking quotations as inputs.
\wordtable{
\vocabulary{kernel}
\ordinaryword{slip}{slip ( quot x -- x | quot:~-- )}
] pull-in
compile? [
+ unix? [
+ "/library/unix/types.factor"
+ ] pull-in
+
os "freebsd" = [
"/library/unix/syscalls-freebsd.factor"
] pull-in
: write-word ( word -- )
"64-bits" get [
- "big-endian" get [ write-be64 ] [ write-le64 ] ifte
+ "big-endian" get [ write-be8 ] [ write-le8 ] ifte
] [
- "big-endian" get [ write-be32 ] [ write-le32 ] ifte
+ "big-endian" get [ write-be4 ] [ write-le4 ] ifte
] ifte ;
: write-image ( image file -- )
[ "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
[ "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] ]
[ "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
- [ "grow-array" "kernel-internals" [ [ integer array ] [ array ] ] ]
- [ "grow-string" "kernel-internals" [ [ integer string ] [ string ] ] ]
+ [ "resize-array" "kernel-internals" [ [ integer array ] [ array ] ] ]
+ [ "resize-string" "strings" [ [ integer string ] [ string ] ] ]
[ "<hashtable>" "hashtables" [ [ number ] [ hashtable ] ] ]
[ "<array>" "kernel-internals" [ [ number ] [ array ] ] ]
[ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ]
! low-level... but be aware that vectors are usually a better
! choice.
-IN: math
-DEFER: repeat
-
IN: kernel-internals
USING: kernel math-internals sequences ;
: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline
: dispatch ( n vtable -- ) 2 slot array-nth call ;
-: copy-array ( to from -- )
- dup array-capacity [
- 3dup swap array-nth pick rot set-array-nth
- ] repeat 2drop ;
-
M: array length array-capacity ;
M: array nth array-nth ;
M: array set-nth set-array-nth ;
-M: array (grow) grow-array ;
+M: array resize resize-array ;
M: hashtable clone ( hash -- hash )
dup bucket-count <hashtable>
over hash-size over set-hash-size
- [ hash-array swap hash-array copy-array ] keep ;
+ [ hash-array swap hash-array copy-into ] keep ;
M: hashtable = ( obj hash -- ? )
2dup eq? [
IN: strings
USING: generic sequences ;
-M: string (grow) grow-string ;
+M: string resize resize-string ;
DEFER: sbuf?
BUILTIN: sbuf 13 sbuf?
[ 2 underlying set-underlying ] ;
M: sbuf set-length ( n sbuf -- )
- growable-check 2dup grow set-capacity ;
+ growable-check 2dup expand set-capacity ;
M: sbuf nth ( n sbuf -- ch )
bounds-check underlying char-slot ;
M: object reverse ( seq -- seq ) [ nreverse ] immutable ;
+: copy-into ( to from -- )
+ dup length [ 3dup swap nth pick rot set-nth ] repeat 3drop ;
+
! Equality testing
: length= ( seq seq -- ? ) length swap length number= ;
GENERIC: head ( n seq -- seq )
GENERIC: tail ( n seq -- seq )
GENERIC: concat ( seq -- seq )
+GENERIC: resize ( n seq -- seq )
G: each ( seq quot -- | quot: elt -- )
[ over ] [ type ] ; inline
GENERIC: underlying
GENERIC: set-underlying
GENERIC: set-capacity
-GENERIC: (grow)
-: grow ( len seq -- )
- #! If the sequence cannot accomodate len elements, resize it
- #! to exactly len.
- [ underlying (grow) ] keep set-underlying ;
+: expand ( len seq -- )
+ [ underlying resize ] keep set-underlying ;
: ensure ( n seq -- )
#! If n is beyond the sequence's length, increase the length,
2dup length fixnum>= [
>r 1 fixnum+ r>
2dup underlying length fixnum> [
- over 2 fixnum* over grow
+ over 2 fixnum* over expand
] when
set-capacity
] [
[ 2 underlying set-underlying ] ;
M: vector set-length ( len vec -- )
- growable-check 2dup grow set-capacity ;
+ growable-check 2dup expand set-capacity ;
M: vector nth ( n vec -- obj )
bounds-check underlying array-nth ;
! slot 2 - the class, a word
! slot 3 - the delegate tuple, or f
+: copy-array ( to from -- )
+ dup array-capacity [
+ 3dup swap array-nth pick rot set-array-nth
+ ] repeat 2drop ;
+
: make-tuple ( class size -- tuple )
#! Internal allocation function. Do not call it directly,
#! since you can fool the runtime and corrupt memory by
C: buffer ( size -- buffer )
2dup set-buffer-size
- swap malloc check-ptr swap [ set-buffer-ptr ] keep
- 0 swap [ set-buffer-fill ] keep
- 0 swap [ set-buffer-pos ] keep ;
+ [ >r malloc check-ptr r> set-buffer-ptr ] keep
+ 0 over set-buffer-fill
+ 0 over set-buffer-pos ;
: buffer-free ( buffer -- )
#! Frees the C memory associated with the buffer.
[ buffer-fill min ] keep
[ set-buffer-pos ] keep
dup buffer-pos over buffer-fill = [
- [ 0 swap set-buffer-pos ] keep
- [ 0 swap set-buffer-fill ] keep
+ 0 over set-buffer-pos
+ 0 over set-buffer-fill
] when drop ;
: buffer@ ( buffer -- int ) dup buffer-ptr swap buffer-pos + ;
2dup buffer-ptr string>memory
>r length r> buffer-reset ;
-: string>buffer ( string - -buffer )
+: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: stdio
-USING: kernel math ;
+USING: kernel lists math sequences strings ;
-: read-le32 ( -- word )
- read1
- read1 8 shift bitor
- read1 16 shift bitor
- read1 24 shift bitor ;
+: be> ( seq -- x ) 0 swap [ >r 8 shift r> bitor ] each ;
+: le> ( seq -- x ) reverse be> ;
-: read-be32 ( -- word )
- read1 24 shift
- read1 16 shift bitor
- read1 8 shift bitor
- read1 bitor ;
+: nth-byte ( x n -- b ) -8 * shift HEX: ff bitand ;
-: byte7 ( num -- byte ) -56 shift HEX: ff bitand ;
-: byte6 ( num -- byte ) -48 shift HEX: ff bitand ;
-: byte5 ( num -- byte ) -40 shift HEX: ff bitand ;
-: byte4 ( num -- byte ) -32 shift HEX: ff bitand ;
-: byte3 ( num -- byte ) -24 shift HEX: ff bitand ;
-: byte2 ( num -- byte ) -16 shift HEX: ff bitand ;
-: byte1 ( num -- byte ) -8 shift HEX: ff bitand ;
-: byte0 ( num -- byte ) HEX: ff bitand ;
+: >le ( x n -- string ) [ nth-byte ] project-with >string ;
+: >be ( x n -- string ) >le reverse ;
-: write-le64 ( word -- )
- dup byte0 write
- dup byte1 write
- dup byte2 write
- dup byte3 write
- dup byte4 write
- dup byte5 write
- dup byte6 write
- byte7 write ;
+: read-le2 ( -n) 2 read le> ; : read-be2 ( -n) 2 read be> ;
+: read-le4 ( -n) 4 read le> ; : read-be4 ( -n) 4 read be> ;
+: read-le8 ( -n) 8 read le> ; : read-be8 ( -n) 8 read be> ;
-: write-be64 ( word -- )
- dup byte7 write
- dup byte6 write
- dup byte5 write
- dup byte4 write
- dup byte3 write
- dup byte2 write
- dup byte1 write
- byte0 write ;
-
-: write-le32 ( word -- )
- dup byte0 write
- dup byte1 write
- dup byte2 write
- byte3 write ;
-
-: write-be32 ( word -- )
- dup byte3 write
- dup byte2 write
- dup byte1 write
- byte0 write ;
-
-: write-le16 ( char -- )
- dup byte0 write
- byte1 write ;
-
-: write-be16 ( char -- )
- dup byte1 write
- byte0 write ;
+: write-le2 ( n-) 2 >le write ; : write-be2 ( n-) 2 >be write ;
+: write-le4 ( n-) 4 >le write ; : write-be4 ( n-) 4 >be write ;
+: write-le8 ( n-) 8 >le write ; : write-be8 ( n-) 8 >be write ;
! captured with with-string.
: write-packet ( string -- )
- dup length write-be32 write flush ;
+ dup length write-be4 write flush ;
-: read-packet ( -- string )
- read-be32 read ;
+: read-packet ( -- string ) read-be4 read ;
: wire-server ( -- )
#! Repeatedly read jEdit requests and execute them. Return
: jedit-write-attr ( str style -- )
CHAR: w write
[ swap . . ] with-string
- dup length write-be32
+ dup length write-be4
write ;
TUPLE: jedit-stream ;
M: jedit-stream stream-readln ( stream -- str )
- [ CHAR: r write flush read-be32 read ] with-wrapper ;
+ [ CHAR: r write flush read-be4 read ] with-wrapper ;
M: jedit-stream stream-write-attr ( str style stream -- )
[ jedit-write-attr ] with-wrapper ;
: send-jedit-request ( request -- )
jedit-server-info swap "localhost" swap <client> [
- write-be32
- dup length write-be16
+ write-be4
+ dup length write-be2
write flush
] with-stream ;
! Alien wrappers for various Unix libc functions.
-ALIAS: ulonglong off_t
-ALIAS: long ssize_t
-ALIAS: ulong size_t
-ALIAS: uint socklen_t
-ALIAS: uint in_addr_t
-
: EINPROGRESS 36 ;
: errno ( -- n )
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: unix-internals
+USING: alien errors kernel math namespaces ;
+
+ALIAS: ulonglong off_t
+ALIAS: long ssize_t
+ALIAS: ulong size_t
+ALIAS: uint socklen_t
+ALIAS: uint in_addr_t
}
/* see note about fill in array() */
-F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
+F_ARRAY* resize_array(F_ARRAY* array, CELL capacity, CELL fill)
{
- int i; F_ARRAY* new_array;
- CELL curr_cap = array_capacity(array);
- if(curr_cap >= capacity)
- return array;
+ int i;
+ F_ARRAY* new_array;
+
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
new_array = allot_array(untag_header(array->header),capacity);
- memcpy(new_array + 1,array + 1,curr_cap * CELLS);
- for(i = curr_cap; i < capacity; i++)
+
+ memcpy(new_array + 1,array + 1,to_copy * CELLS);
+
+ for(i = to_copy; i < capacity; i++)
put(AREF(new_array,i),fill);
+
return new_array;
}
-void primitive_grow_array(void)
+void primitive_resize_array(void)
{
F_ARRAY* array; CELL capacity;
maybe_garbage_collection();
array = untag_array_fast(dpop());
capacity = to_fixnum(dpop());
- dpush(tag_object(grow_array(array,capacity,F)));
-}
-
-F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
-{
- F_ARRAY* new_array = allot_array(untag_header(array->header),capacity);
- memcpy(new_array + 1,array + 1,capacity * CELLS);
- return new_array;
+ dpush(tag_object(resize_array(array,capacity,F)));
}
void fixup_array(F_ARRAY* array)
void primitive_tuple(void);
void primitive_byte_array(void);
-F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
-void primitive_grow_array(void);
-F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
+F_ARRAY* resize_array(F_ARRAY* array, CELL capacity, CELL fill);
+void primitive_resize_array(void);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
primitive_set_integer_slot,
primitive_char_slot,
primitive_set_char_slot,
- primitive_grow_array,
- primitive_grow_string,
+ primitive_resize_array,
+ primitive_resize_string,
primitive_hashtable,
primitive_array,
primitive_tuple,
/* BIGNUM_REDUCE_LENGTH allows the memory system to reclaim some
space when a bignum's length is reduced from its original value. */
#define BIGNUM_REDUCE_LENGTH(target, source, length) \
- target = shrink_array(source, length + 1)
-/* extern F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); */
+ target = resize_array(source, length + 1,0)
/* BIGNUM_DEALLOCATE is called when disposing of bignums which are
created as intermediate temporaries; Scheme doesn't need this. */
return string;
}
-F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
+F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
{
/* later on, do an optimization: if end of array is here, just grow */
CELL i;
- CELL old_capacity = string_capacity(string);
+ CELL to_copy = string_capacity(string);
+
+ if(capacity < to_copy)
+ to_copy = capacity;
F_STRING* new_string = allot_string(capacity);
- memcpy(new_string + 1,string + 1,old_capacity * CHARS);
+ memcpy(new_string + 1,string + 1,to_copy * CHARS);
- for(i = old_capacity; i < capacity; i++)
+ for(i = to_copy; i < capacity; i++)
cput(SREF(new_string,i),fill);
return new_string;
}
-void primitive_grow_string(void)
+void primitive_resize_string(void)
{
F_STRING* string; CELL capacity;
maybe_garbage_collection();
string = untag_string_fast(dpop());
capacity = to_fixnum(dpop());
- dpush(tag_object(grow_string(string,capacity,F)));
+ dpush(tag_object(resize_string(string,capacity,F)));
}
F_STRING* memory_to_string(const BYTE* string, CELL length)
F_STRING* string(CELL capacity, CELL fill);
void rehash_string(F_STRING* str);
void primitive_rehash_string(void);
-F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
-void primitive_grow_string(void);
+F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
+void primitive_resize_string(void);
char* to_c_string(F_STRING* s);
char* to_c_string_unchecked(F_STRING* s);
void string_to_memory(F_STRING* s, BYTE* string);