primitives: Change PRIMITIVE: to check that the word is in that vocabulary and the stack effect is correct.
Use PRIMITIVE: in core/ and basis/db4
parent
fdcbe26cbc
commit
44e8e7b344
|
@ -5,6 +5,12 @@ kernel namespaces destructors sequences strings
|
||||||
system io.pathnames fry combinators vocabs ;
|
system io.pathnames fry combinators vocabs ;
|
||||||
IN: alien.libraries
|
IN: alien.libraries
|
||||||
|
|
||||||
|
PRIMITIVE: dll-valid? ( dll -- ? )
|
||||||
|
PRIMITIVE: (dlopen) ( path -- dll )
|
||||||
|
PRIMITIVE: (dlsym) ( name dll -- alien )
|
||||||
|
PRIMITIVE: dlclose ( dll -- )
|
||||||
|
PRIMITIVE: (dlsym-raw) ( name dll -- alien )
|
||||||
|
|
||||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||||
|
|
||||||
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
||||||
|
|
|
@ -3,6 +3,11 @@
|
||||||
USING: slots.private ;
|
USING: slots.private ;
|
||||||
IN: locals.backend
|
IN: locals.backend
|
||||||
|
|
||||||
|
PRIMITIVE: drop-locals ( n -- )
|
||||||
|
PRIMITIVE: get-local ( n -- obj )
|
||||||
|
PRIMITIVE: load-local ( obj -- )
|
||||||
|
PRIMITIVE: load-locals ( ... n -- )
|
||||||
|
|
||||||
: local-value ( box -- value ) 2 slot ; inline
|
: local-value ( box -- value ) 2 slot ; inline
|
||||||
|
|
||||||
: set-local-value ( value box -- ) 2 set-slot ; inline
|
: set-local-value ( value box -- ) 2 set-slot ; inline
|
||||||
|
|
|
@ -9,6 +9,15 @@ FROM: assocs => change-at ;
|
||||||
IN: threads
|
IN: threads
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
PRIMITIVE: (set-context) ( obj context -- obj' )
|
||||||
|
PRIMITIVE: (set-context-and-delete) ( obj context -- * )
|
||||||
|
PRIMITIVE: (sleep) ( nanos -- )
|
||||||
|
PRIMITIVE: (start-context) ( obj quot -- obj' )
|
||||||
|
PRIMITIVE: (start-context-and-delete) ( obj quot -- * )
|
||||||
|
PRIMITIVE: callstack-for ( context -- array )
|
||||||
|
PRIMITIVE: context-object-for ( n context -- obj )
|
||||||
|
PRIMITIVE: datastack-for ( context -- array )
|
||||||
|
PRIMITIVE: retainstack-for ( context -- array )
|
||||||
|
|
||||||
! Wrap sub-primitives; we don't want them inlined into callers
|
! Wrap sub-primitives; we don't want them inlined into callers
|
||||||
! since their behavior depends on what frames are on the callstack
|
! since their behavior depends on what frames are on the callstack
|
||||||
|
|
|
@ -4,6 +4,11 @@ USING: accessors kernel namespaces prettyprint classes.struct
|
||||||
vm tools.dispatch.private ;
|
vm tools.dispatch.private ;
|
||||||
IN: tools.dispatch
|
IN: tools.dispatch
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: dispatch-stats ( -- stats )
|
||||||
|
PRIMITIVE: reset-dispatch-stats ( -- )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
SYMBOL: last-dispatch-stats
|
SYMBOL: last-dispatch-stats
|
||||||
|
|
||||||
: dispatch-stats. ( -- )
|
: dispatch-stats. ( -- )
|
||||||
|
|
|
@ -9,6 +9,12 @@ splitting strings system vm words hints hashtables ;
|
||||||
IN: tools.memory
|
IN: tools.memory
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
PRIMITIVE: (callback-room) ( -- allocator-room )
|
||||||
|
PRIMITIVE: (code-blocks) ( -- array )
|
||||||
|
PRIMITIVE: (code-room) ( -- allocator-room )
|
||||||
|
PRIMITIVE: (data-room) ( -- data-room )
|
||||||
|
PRIMITIVE: disable-gc-events ( -- events )
|
||||||
|
PRIMITIVE: enable-gc-events ( -- )
|
||||||
|
|
||||||
: commas ( n -- str )
|
: commas ( n -- str )
|
||||||
dup 0 < [ neg commas "-" prepend ] [
|
dup 0 < [ neg commas "-" prepend ] [
|
||||||
|
|
|
@ -8,6 +8,12 @@ FROM: sequences => change-nth ;
|
||||||
FROM: assocs => change-at ;
|
FROM: assocs => change-at ;
|
||||||
IN: tools.profiler.sampling
|
IN: tools.profiler.sampling
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (get-samples) ( -- samples/f )
|
||||||
|
PRIMITIVE: profiling ( ? -- )
|
||||||
|
PRIMITIVE: (clear-samples) ( -- )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
SYMBOL: samples-per-second
|
SYMBOL: samples-per-second
|
||||||
|
|
||||||
samples-per-second [ 1,000 ] initialize
|
samples-per-second [ 1,000 ] initialize
|
||||||
|
|
|
@ -0,0 +1,30 @@
|
||||||
|
! Copyright (C) 2015 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: alien.accessors
|
||||||
|
|
||||||
|
PRIMITIVE: alien-cell ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-double ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-float ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-signed-1 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-signed-2 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-signed-4 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-signed-8 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-signed-cell ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-unsigned-1 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-unsigned-2 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-unsigned-4 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-unsigned-8 ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: alien-unsigned-cell ( c-ptr n -- value )
|
||||||
|
PRIMITIVE: set-alien-cell ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-double ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-float ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-signed-1 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-signed-2 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-signed-4 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-signed-8 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-signed-cell ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-unsigned-1 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-unsigned-2 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-unsigned-4 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-unsigned-8 ( value c-ptr n -- )
|
||||||
|
PRIMITIVE: set-alien-unsigned-cell ( value c-ptr n -- )
|
|
@ -8,6 +8,15 @@ IN: alien
|
||||||
BUILTIN: alien { underlying c-ptr read-only initial: f } expired ;
|
BUILTIN: alien { underlying c-ptr read-only initial: f } expired ;
|
||||||
BUILTIN: dll { path byte-array read-only initial: B{ } } ;
|
BUILTIN: dll { path byte-array read-only initial: B{ } } ;
|
||||||
|
|
||||||
|
PRIMITIVE: <callback> ( word return-rewind -- alien )
|
||||||
|
PRIMITIVE: <displaced-alien> ( displacement c-ptr -- alien )
|
||||||
|
PRIMITIVE: alien-address ( c-ptr -- addr )
|
||||||
|
PRIMITIVE: free-callback ( alien -- )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: current-callback ( -- n )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
PREDICATE: pinned-alien < alien underlying>> not ;
|
PREDICATE: pinned-alien < alien underlying>> not ;
|
||||||
|
|
||||||
UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
|
UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
|
||||||
|
|
|
@ -5,6 +5,9 @@ IN: arrays
|
||||||
|
|
||||||
BUILTIN: array { length array-capacity read-only initial: 0 } ;
|
BUILTIN: array { length array-capacity read-only initial: 0 } ;
|
||||||
|
|
||||||
|
PRIMITIVE: <array> ( n elt -- array )
|
||||||
|
PRIMITIVE: resize-array ( n array -- new-array )
|
||||||
|
|
||||||
M: array clone (clone) ; inline
|
M: array clone (clone) ; inline
|
||||||
M: array length length>> ; inline
|
M: array length length>> ; inline
|
||||||
M: array nth-unsafe [ integer>fixnum ] dip array-nth ; inline
|
M: array nth-unsafe [ integer>fixnum ] dip array-nth ; inline
|
||||||
|
|
|
@ -7,6 +7,10 @@ IN: byte-arrays
|
||||||
BUILTIN: byte-array
|
BUILTIN: byte-array
|
||||||
{ length array-capacity read-only initial: 0 } ;
|
{ length array-capacity read-only initial: 0 } ;
|
||||||
|
|
||||||
|
PRIMITIVE: (byte-array) ( n -- byte-array )
|
||||||
|
PRIMITIVE: <byte-array> ( n -- byte-array )
|
||||||
|
PRIMITIVE: resize-byte-array ( n byte-array -- new-byte-array )
|
||||||
|
|
||||||
M: byte-array clone (clone) ; inline
|
M: byte-array clone (clone) ; inline
|
||||||
M: byte-array clone-like
|
M: byte-array clone-like
|
||||||
over byte-array? [ drop clone ] [ call-next-method ] if ; inline
|
over byte-array? [ drop clone ] [ call-next-method ] if ; inline
|
||||||
|
|
|
@ -7,6 +7,11 @@ make math math.private memory namespaces quotations sequences
|
||||||
sequences.private slots slots.private strings words ;
|
sequences.private slots slots.private strings words ;
|
||||||
IN: classes.tuple
|
IN: classes.tuple
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: <tuple> ( layout -- tuple )
|
||||||
|
PRIMITIVE: <tuple-boa> ( slots... layout -- tuple )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
PREDICATE: tuple-class < class
|
PREDICATE: tuple-class < class
|
||||||
"metaclass" word-prop tuple-class eq? ;
|
"metaclass" word-prop tuple-class eq? ;
|
||||||
|
|
||||||
|
|
|
@ -8,6 +8,8 @@ FROM: namespaces => set ;
|
||||||
FROM: sets => members ;
|
FROM: sets => members ;
|
||||||
IN: compiler.units
|
IN: compiler.units
|
||||||
|
|
||||||
|
PRIMITIVE: modify-code-heap ( alist update-existing? reset-pics? -- )
|
||||||
|
|
||||||
SYMBOL: old-definitions
|
SYMBOL: old-definitions
|
||||||
SYMBOL: new-definitions
|
SYMBOL: new-definitions
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,14 @@ sequences words ;
|
||||||
FROM: assocs => change-at ;
|
FROM: assocs => change-at ;
|
||||||
IN: generic.single
|
IN: generic.single
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: inline-cache-miss ( generic methods index cache -- )
|
||||||
|
PRIMITIVE: inline-cache-miss-tail ( generic methods index cache -- )
|
||||||
|
PRIMITIVE: lookup-method ( object methods -- method )
|
||||||
|
PRIMITIVE: mega-cache-lookup ( methods index cache -- )
|
||||||
|
PRIMITIVE: mega-cache-miss ( methods index cache -- method )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
ERROR: no-method object generic ;
|
ERROR: no-method object generic ;
|
||||||
|
|
||||||
ERROR: inconsistent-next-method class generic ;
|
ERROR: inconsistent-next-method class generic ;
|
||||||
|
|
|
@ -5,6 +5,10 @@ io.encodings io.encodings.utf8 io.files.private io.pathnames
|
||||||
kernel kernel.private namespaces sequences splitting system ;
|
kernel kernel.private namespaces sequences splitting system ;
|
||||||
IN: io.files
|
IN: io.files
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (exists?) ( path -- ? )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||||
SYMBOL: +input+
|
SYMBOL: +input+
|
||||||
SYMBOL: +output+
|
SYMBOL: +output+
|
||||||
|
|
|
@ -5,6 +5,16 @@ destructors io io.backend io.encodings.utf8 io.files kernel
|
||||||
kernel.private math sequences threads.private ;
|
kernel.private math sequences threads.private ;
|
||||||
IN: io.streams.c
|
IN: io.streams.c
|
||||||
|
|
||||||
|
PRIMITIVE: (fopen) ( path mode -- alien )
|
||||||
|
PRIMITIVE: fclose ( alien -- )
|
||||||
|
PRIMITIVE: fflush ( alien -- )
|
||||||
|
PRIMITIVE: fgetc ( alien -- byte/f )
|
||||||
|
PRIMITIVE: fputc ( byte alien -- )
|
||||||
|
PRIMITIVE: fread-unsafe ( n buf alien -- count )
|
||||||
|
PRIMITIVE: fseek ( alien offset whence -- )
|
||||||
|
PRIMITIVE: ftell ( alien -- n )
|
||||||
|
PRIMITIVE: fwrite ( data length alien -- )
|
||||||
|
|
||||||
TUPLE: c-stream < disposable handle ;
|
TUPLE: c-stream < disposable handle ;
|
||||||
|
|
||||||
: new-c-stream ( handle class -- c-stream )
|
: new-c-stream ( handle class -- c-stream )
|
||||||
|
|
|
@ -7,6 +7,65 @@ BUILTIN: callstack ;
|
||||||
BUILTIN: tuple ;
|
BUILTIN: tuple ;
|
||||||
BUILTIN: wrapper { wrapped read-only } ;
|
BUILTIN: wrapper { wrapped read-only } ;
|
||||||
|
|
||||||
|
PRIMITIVE: -rot ( x y z -- z x y )
|
||||||
|
PRIMITIVE: dup ( x -- x x )
|
||||||
|
PRIMITIVE: dupd ( x y -- x x y )
|
||||||
|
PRIMITIVE: drop ( x -- )
|
||||||
|
PRIMITIVE: nip ( x y -- y )
|
||||||
|
PRIMITIVE: over ( x y -- x y x )
|
||||||
|
PRIMITIVE: pick ( x y z -- x y z x )
|
||||||
|
PRIMITIVE: rot ( x y z -- y z x )
|
||||||
|
PRIMITIVE: swap ( x y -- y x )
|
||||||
|
PRIMITIVE: swapd ( x y z -- y x z )
|
||||||
|
PRIMITIVE: 2drop ( x y -- )
|
||||||
|
PRIMITIVE: 2dup ( x y -- x y x y )
|
||||||
|
PRIMITIVE: 2nip ( x y z -- z )
|
||||||
|
PRIMITIVE: 3drop ( x y z -- )
|
||||||
|
PRIMITIVE: 3dup ( x y z -- x y z x y z )
|
||||||
|
PRIMITIVE: 4drop ( w x y z -- )
|
||||||
|
PRIMITIVE: 4dup ( w x y z -- w x y z w x y z )
|
||||||
|
|
||||||
|
PRIMITIVE: (clone) ( obj -- newobj )
|
||||||
|
PRIMITIVE: eq? ( obj1 obj2 -- ? )
|
||||||
|
PRIMITIVE: <wrapper> ( obj -- wrapper )
|
||||||
|
PRIMITIVE: callstack ( -- callstack )
|
||||||
|
PRIMITIVE: datastack ( -- array )
|
||||||
|
PRIMITIVE: retainstack ( -- array )
|
||||||
|
PRIMITIVE: die ( -- )
|
||||||
|
PRIMITIVE: callstack>array ( callstack -- array )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (call) ( quot -- )
|
||||||
|
PRIMITIVE: (execute) ( word -- )
|
||||||
|
PRIMITIVE: (identity-hashcode) ( obj -- code )
|
||||||
|
PRIMITIVE: become ( old new -- )
|
||||||
|
PRIMITIVE: c-to-factor ( -- )
|
||||||
|
PRIMITIVE: callstack-bounds ( -- start end )
|
||||||
|
PRIMITIVE: check-datastack ( array in# out# -- ? )
|
||||||
|
PRIMITIVE: compute-identity-hashcode ( obj -- )
|
||||||
|
PRIMITIVE: context-object ( n -- obj )
|
||||||
|
PRIMITIVE: ffi-leaf-signal-handler ( -- )
|
||||||
|
PRIMITIVE: ffi-signal-handler ( -- )
|
||||||
|
PRIMITIVE: fpu-state ( -- )
|
||||||
|
PRIMITIVE: innermost-frame-executing ( callstack -- obj )
|
||||||
|
PRIMITIVE: innermost-frame-scan ( callstack -- n )
|
||||||
|
PRIMITIVE: lazy-jit-compile ( -- )
|
||||||
|
PRIMITIVE: leaf-signal-handler ( -- )
|
||||||
|
PRIMITIVE: set-callstack ( callstack -- * )
|
||||||
|
PRIMITIVE: set-context-object ( obj n -- )
|
||||||
|
PRIMITIVE: set-datastack ( array -- )
|
||||||
|
PRIMITIVE: set-fpu-state ( -- )
|
||||||
|
PRIMITIVE: set-innermost-frame-quot ( n callstack -- )
|
||||||
|
PRIMITIVE: set-retainstack ( array -- )
|
||||||
|
PRIMITIVE: set-special-object ( obj n -- )
|
||||||
|
PRIMITIVE: signal-handler ( -- )
|
||||||
|
PRIMITIVE: special-object ( n -- obj )
|
||||||
|
PRIMITIVE: strip-stack-traces ( -- )
|
||||||
|
PRIMITIVE: tag ( object -- n )
|
||||||
|
PRIMITIVE: unimplemented ( -- * )
|
||||||
|
PRIMITIVE: unwind-native-frames ( -- )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
DEFER: dip
|
DEFER: dip
|
||||||
DEFER: 2dip
|
DEFER: 2dip
|
||||||
DEFER: 3dip
|
DEFER: 3dip
|
||||||
|
|
|
@ -7,6 +7,74 @@ BUILTIN: fixnum ;
|
||||||
BUILTIN: bignum ;
|
BUILTIN: bignum ;
|
||||||
BUILTIN: float ;
|
BUILTIN: float ;
|
||||||
|
|
||||||
|
PRIMITIVE: bits>double ( n -- x )
|
||||||
|
PRIMITIVE: bits>float ( n -- x )
|
||||||
|
PRIMITIVE: double>bits ( x -- n )
|
||||||
|
PRIMITIVE: float>bits ( x -- n )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: bignum* ( x y -- z )
|
||||||
|
PRIMITIVE: bignum+ ( x y -- z )
|
||||||
|
PRIMITIVE: bignum- ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-bit? ( x n -- ? )
|
||||||
|
PRIMITIVE: bignum-bitand ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-bitnot ( x -- y )
|
||||||
|
PRIMITIVE: bignum-bitor ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-bitxor ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-gcd ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-log2 ( x -- n )
|
||||||
|
PRIMITIVE: bignum-mod ( x y -- z )
|
||||||
|
PRIMITIVE: bignum-shift ( x y -- z )
|
||||||
|
PRIMITIVE: bignum/i ( x y -- z )
|
||||||
|
PRIMITIVE: bignum/mod ( x y -- z w )
|
||||||
|
PRIMITIVE: bignum< ( x y -- ? )
|
||||||
|
PRIMITIVE: bignum<= ( x y -- ? )
|
||||||
|
PRIMITIVE: bignum= ( x y -- ? )
|
||||||
|
PRIMITIVE: bignum> ( x y -- ? )
|
||||||
|
PRIMITIVE: bignum>= ( x y -- ? )
|
||||||
|
PRIMITIVE: bignum>fixnum ( x -- y )
|
||||||
|
PRIMITIVE: bignum>fixnum-strict ( x -- y )
|
||||||
|
PRIMITIVE: both-fixnums? ( x y -- ? )
|
||||||
|
PRIMITIVE: fixnum* ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum*fast ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum+ ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum+fast ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum- ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-bitand ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-bitnot ( x -- y )
|
||||||
|
PRIMITIVE: fixnum-bitor ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-bitxor ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-fast ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-mod ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-shift ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum-shift-fast ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum/i ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum/i-fast ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum/mod ( x y -- z w )
|
||||||
|
PRIMITIVE: fixnum/mod-fast ( x y -- z w )
|
||||||
|
PRIMITIVE: fixnum< ( x y -- ? )
|
||||||
|
PRIMITIVE: fixnum<= ( x y -- z )
|
||||||
|
PRIMITIVE: fixnum> ( x y -- ? )
|
||||||
|
PRIMITIVE: fixnum>= ( x y -- ? )
|
||||||
|
PRIMITIVE: fixnum>bignum ( x -- y )
|
||||||
|
PRIMITIVE: fixnum>float ( x -- y )
|
||||||
|
PRIMITIVE: float* ( x y -- z )
|
||||||
|
PRIMITIVE: float+ ( x y -- z )
|
||||||
|
PRIMITIVE: float- ( x y -- z )
|
||||||
|
PRIMITIVE: float-u< ( x y -- ? )
|
||||||
|
PRIMITIVE: float-u<= ( x y -- ? )
|
||||||
|
PRIMITIVE: float-u> ( x y -- ? )
|
||||||
|
PRIMITIVE: float-u>= ( x y -- ? )
|
||||||
|
PRIMITIVE: float/f ( x y -- z )
|
||||||
|
PRIMITIVE: float< ( x y -- ? )
|
||||||
|
PRIMITIVE: float<= ( x y -- ? )
|
||||||
|
PRIMITIVE: float= ( x y -- ? )
|
||||||
|
PRIMITIVE: float> ( x y -- ? )
|
||||||
|
PRIMITIVE: float>= ( x y -- ? )
|
||||||
|
PRIMITIVE: float>bignum ( x -- y )
|
||||||
|
PRIMITIVE: float>fixnum ( x -- y )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
GENERIC: >fixnum ( x -- n ) foldable
|
GENERIC: >fixnum ( x -- n ) foldable
|
||||||
GENERIC: >bignum ( x -- n ) foldable
|
GENERIC: >bignum ( x -- n ) foldable
|
||||||
GENERIC: >integer ( x -- n ) foldable
|
GENERIC: >integer ( x -- n ) foldable
|
||||||
|
|
|
@ -5,6 +5,10 @@ layouts make math math.private namespaces sbufs sequences
|
||||||
sequences.private splitting strings strings.private ;
|
sequences.private splitting strings strings.private ;
|
||||||
IN: math.parser
|
IN: math.parser
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (format-float) ( n format -- byte-array )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: digit> ( ch -- n )
|
: digit> ( ch -- n )
|
||||||
{
|
{
|
||||||
{ [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
|
{ [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
|
||||||
|
|
|
@ -4,6 +4,17 @@ USING: alien.strings io.backend kernel memory.private sequences
|
||||||
system ;
|
system ;
|
||||||
IN: memory
|
IN: memory
|
||||||
|
|
||||||
|
PRIMITIVE: all-instances ( -- array )
|
||||||
|
PRIMITIVE: compact-gc ( -- )
|
||||||
|
PRIMITIVE: gc ( -- )
|
||||||
|
PRIMITIVE: minor-gc ( -- )
|
||||||
|
PRIMITIVE: size ( obj -- n )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (save-image) ( path1 path2 -- )
|
||||||
|
PRIMITIVE: (save-image-and-exit) ( path1 path2 -- )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: instances ( quot -- seq )
|
: instances ( quot -- seq )
|
||||||
[ all-instances ] dip filter ; inline
|
[ all-instances ] dip filter ; inline
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,12 @@ BUILTIN: quotation
|
||||||
cached-effect
|
cached-effect
|
||||||
cache-counter ;
|
cache-counter ;
|
||||||
|
|
||||||
|
PRIMITIVE: jit-compile ( quot -- )
|
||||||
|
PRIMITIVE: quot-compiled? ( quot -- ? )
|
||||||
|
PRIMITIVE: quotation-code ( quot -- start end )
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
PRIMITIVE: array>quotation ( array -- quot )
|
||||||
|
|
||||||
: uncurry ( curry -- obj quot )
|
: uncurry ( curry -- obj quot )
|
||||||
{ curry } declare dup 2 slot swap 3 slot ; inline
|
{ curry } declare dup 2 slot swap 3 slot ; inline
|
||||||
|
|
|
@ -7,6 +7,11 @@ kernel.private make math quotations sequences sequences.private
|
||||||
slots.private strings words ;
|
slots.private strings words ;
|
||||||
IN: slots
|
IN: slots
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: set-slot ( value obj n -- )
|
||||||
|
PRIMITIVE: slot ( obj m -- value )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
TUPLE: slot-spec name offset class initial read-only ;
|
TUPLE: slot-spec name offset class initial read-only ;
|
||||||
|
|
||||||
PREDICATE: reader < word "reader" word-prop ;
|
PREDICATE: reader < word "reader" word-prop ;
|
||||||
|
|
|
@ -7,7 +7,12 @@ IN: strings
|
||||||
|
|
||||||
BUILTIN: string { length array-capacity read-only initial: 0 } aux ;
|
BUILTIN: string { length array-capacity read-only initial: 0 } aux ;
|
||||||
|
|
||||||
|
PRIMITIVE: <string> ( n ch -- string )
|
||||||
|
PRIMITIVE: resize-string ( n str -- newstr )
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
PRIMITIVE: set-string-nth-fast ( ch n string -- )
|
||||||
|
PRIMITIVE: string-nth-fast ( n string -- ch )
|
||||||
|
|
||||||
: string-hashcode ( str -- n ) 3 slot ; inline
|
: string-hashcode ( str -- n ) 3 slot ; inline
|
||||||
|
|
||||||
|
|
|
@ -31,7 +31,8 @@ IN: bootstrap.syntax
|
||||||
{ "]" "}" ";" ">>" } [ define-delimiter ] each
|
{ "]" "}" ";" ">>" } [ define-delimiter ] each
|
||||||
|
|
||||||
"PRIMITIVE:" [
|
"PRIMITIVE:" [
|
||||||
"Primitive definition is not supported" throw
|
current-vocab name>>
|
||||||
|
scan-word scan-effect ensure-primitive
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
||||||
"CS{" [
|
"CS{" [
|
||||||
|
|
|
@ -4,6 +4,9 @@ USING: assocs continuations init io kernel kernel.private make
|
||||||
math.parser namespaces sequences ;
|
math.parser namespaces sequences ;
|
||||||
IN: system
|
IN: system
|
||||||
|
|
||||||
|
PRIMITIVE: (exit) ( n -- * )
|
||||||
|
PRIMITIVE: nano-count ( -- ns )
|
||||||
|
|
||||||
SINGLETONS: x86.32 x86.64 arm ppc.32 ppc.64 ;
|
SINGLETONS: x86.32 x86.64 arm ppc.32 ppc.64 ;
|
||||||
|
|
||||||
UNION: x86 x86.32 x86.64 ;
|
UNION: x86 x86.32 x86.64 ;
|
||||||
|
|
|
@ -11,6 +11,13 @@ BUILTIN: word
|
||||||
{ def quotation initial: [ ] } props pic-def pic-tail-def
|
{ def quotation initial: [ ] } props pic-def pic-tail-def
|
||||||
{ sub-primitive read-only } ;
|
{ sub-primitive read-only } ;
|
||||||
|
|
||||||
|
PRIMITIVE: optimized? ( word -- ? )
|
||||||
|
PRIMITIVE: word-code ( word -- start end )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
PRIMITIVE: (word) ( name vocab hashcode -- word )
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
! Need a dummy word here because BUILTIN: word is not a real word
|
! Need a dummy word here because BUILTIN: word is not a real word
|
||||||
! and parse-datum looks for things that are actually words instead of
|
! and parse-datum looks for things that are actually words instead of
|
||||||
! also looking for classes
|
! also looking for classes
|
||||||
|
@ -68,6 +75,14 @@ PREDICATE: primitive < word "primitive" word-prop ;
|
||||||
M: primitive definer drop \ PRIMITIVE: f ;
|
M: primitive definer drop \ PRIMITIVE: f ;
|
||||||
M: primitive definition drop f ;
|
M: primitive definition drop f ;
|
||||||
|
|
||||||
|
ERROR: invalid-primitive vocabulary word effect ;
|
||||||
|
: ensure-primitive ( vocabulary word effect -- )
|
||||||
|
3dup
|
||||||
|
[ drop vocabulary>> = ]
|
||||||
|
[ drop nip primitive? ]
|
||||||
|
[ [ nip "declared-effect" word-prop ] dip = ] 3tri and and
|
||||||
|
[ 3drop ] [ invalid-primitive ] if ;
|
||||||
|
|
||||||
: lookup-word ( name vocab -- word ) vocab-words-assoc at ;
|
: lookup-word ( name vocab -- word ) vocab-words-assoc at ;
|
||||||
|
|
||||||
: target-word ( word -- target )
|
: target-word ( word -- target )
|
||||||
|
|
Loading…
Reference in New Issue