<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
<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
! if it is somewhat 'implementation detail', is in the
! public 'hashtables' vocabulary.
+: bucket-count ( hash -- n ) hash-array length ;
+
IN: kernel-internals
: hash-bucket ( n hash -- alist )
IN: hashtables
-: bucket-count ( hash -- n ) hash-array length ;
-
: (hashcode) ( key table -- index )
#! Compute the index of the bucket for a key.
>r hashcode r> bucket-count rem ; inline
: typed-literal? ( node -- ? )
#! Output if the node's first input is well-typed, and the
#! second is a literal.
- dup node-peek literal? swap node-peek-2 typed? and ;
+ dup node-peek safe-literal? swap node-peek-2 typed? and ;
\ slot [
dup typed-literal? [
0 0 %replace-d , ; inline
: literal-fixnum? ( value -- ? )
- dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
+ dup safe-literal? [ literal-value fixnum? ] [ drop f ] ifte ;
: binary-op-imm ( imm op -- )
1 %dec-d , in-1
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
-USING: compiler-backend inference kernel kernel-internals lists
-math namespaces words strings errors prettyprint sequences ;
+USING: compiler-backend errors generic inference kernel
+kernel-internals lists math namespaces prettyprint sequences
+strings words ;
GENERIC: linearize-node* ( node -- )
M: f linearize-node* ( f -- ) drop ;
GENERIC: load-value ( vreg n value -- )
-M: computed load-value ( vreg n value -- )
+M: object load-value ( vreg n value -- )
drop %peek-d , ;
-M: literal load-value ( vreg n value -- )
- nip literal-value dup
+: push-literal ( vreg value -- )
+ literal-value dup
immediate? [ %immediate ] [ %indirect ] ifte , ;
-: push-1 ( value -- ) >r 0 0 r> load-value ;
+M: safe-literal load-value ( vreg n value -- )
+ nip push-literal ;
+
+: push-1 ( value -- ) 0 swap push-literal ;
M: #push linearize-node* ( node -- )
node-out-d dup length dup %inc-d ,
: stack@ 3 + cell * ;
M: %parameters generate-node ( vop -- )
- dup 0 = [ drop ] [ stack-size 1 1 rot SUBI ] ifte ;
+ vop-in-1 dup 0 = [ drop ] [ stack-size 1 1 rot SUBI ] ifte ;
M: %unbox generate-node ( vop -- )
vop-in-1 uncons f compile-c-call 3 1 rot stack@ STW ;
: cs-op cell * neg 15 swap ;
M: %immediate generate-node ( vop -- )
- dup vop-in-1 address swap vop-out-1 v>operand LOAD32 ;
+ dup vop-in-1 address swap vop-out-1 v>operand LOAD ;
: load-indirect ( dest literal -- )
intern-literal over LOAD dup 0 LWZ ;
VOP: %set-slot
: %set-slot ( value obj n )
#! %set-slot writes to vreg n.
- >r >r <vreg> r> <vreg> r> <vreg> [ 3list ] keep unit f
+ >r >r <vreg> r> <vreg> r> <vreg> 3list dup second f
<%set-slot> ;
M: %set-slot basic-block? drop t ;
M: %fast-set-slot basic-block? drop t ;
VOP: %write-barrier
-: %write-barrier ( ptr ) <vreg> unit f f <%write-barrier> ;
+: %write-barrier ( ptr ) <vreg> unit dup f <%write-barrier> ;
! fixnum intrinsics
VOP: %fixnum+ : %fixnum+ 3-vop <%fixnum+> ;
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
-GENERIC: safe-literal? ( value -- ? )
SYMBOL: cloned
GENERIC: clone-value ( value -- value )
M: literal set-value-class ( class value -- )
2drop ;
-M: literal safe-literal? ( value -- ? ) value-safe? ;
-
M: computed clone-value ( value -- value )
dup cloned get assq [ ] [
dup clone [ swap cloned [ acons ] change ] keep
] ?ifte ;
-M: computed safe-literal? drop f ;
-
M: computed literal-value ( value -- )
"A literal value was expected where a computed value was"
" found: " rot unparse append3 inference-error ;
: >literal< ( literal -- rstate obj )
dup value-recursion swap literal-value ;
+
+PREDICATE: tuple safe-literal ( obj -- ? )
+ dup literal? [ value-safe? ] [ drop f ] ifte ;
: log2 ( n -- b )
#! Log base two for integers.
- dup 0 < [
+ dup 0 <= [
"Input must be positive" throw
] [
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
[
M[ [ 1 ] [ 2 ] [ 3 ] ]M
] [
- { 1 2 3 } <col-vector>
+ { 1 2 3 } <col-matrix>
] unit-test
[
"httpd/url-encoding" "httpd/html" "httpd/httpd"
"httpd/http-client"
"crashes" "sbuf" "threads" "parsing-word"
- "inference" "dataflow" "interpreter" "alien"
+ "inference" "interpreter" "alien"
"line-editor" "gadgets" "memory" "redefine"
"annotate" "sequences"
] run-tests ;
! Hashcode breakage
TUPLE: empty ;
[ t ] [ <empty> hashcode fixnum? ] unit-test
+
+TUPLE: delegate-clone ;
+
+[ << delegate-clone << empty f >> >> ]
+[ << delegate-clone << empty f >> >> clone ] unit-test