system io.pathnames fry combinators vocabs ;
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) ;
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
USING: slots.private ;
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
: set-local-value ( value box -- ) 2 set-slot ; inline
IN: threads
<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
! since their behavior depends on what frames are on the callstack
vm tools.dispatch.private ;
IN: tools.dispatch
+<PRIVATE
+PRIMITIVE: dispatch-stats ( -- stats )
+PRIMITIVE: reset-dispatch-stats ( -- )
+PRIVATE>
+
SYMBOL: last-dispatch-stats
: dispatch-stats. ( -- )
IN: tools.memory
<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 )
dup 0 < [ neg commas "-" prepend ] [
FROM: assocs => change-at ;
IN: tools.profiler.sampling
+<PRIVATE
+PRIMITIVE: (get-samples) ( -- samples/f )
+PRIMITIVE: profiling ( ? -- )
+PRIMITIVE: (clear-samples) ( -- )
+PRIVATE>
+
SYMBOL: samples-per-second
samples-per-second [ 1,000 ] initialize
--- /dev/null
+! 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 -- )
BUILTIN: alien { underlying c-ptr read-only initial: f } expired ;
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 ;
UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
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 length length>> ; inline
M: array nth-unsafe [ integer>fixnum ] dip array-nth ; inline
BUILTIN: byte-array
{ 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-like
over byte-array? [ drop clone ] [ call-next-method ] if ; inline
sequences.private slots slots.private strings words ;
IN: classes.tuple
+<PRIVATE
+PRIMITIVE: <tuple> ( layout -- tuple )
+PRIMITIVE: <tuple-boa> ( slots... layout -- tuple )
+PRIVATE>
+
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
FROM: sets => members ;
IN: compiler.units
+PRIMITIVE: modify-code-heap ( alist update-existing? reset-pics? -- )
+
SYMBOL: old-definitions
SYMBOL: new-definitions
FROM: assocs => change-at ;
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: inconsistent-next-method class generic ;
kernel kernel.private namespaces sequences splitting system ;
IN: io.files
+<PRIVATE
+PRIMITIVE: (exists?) ( path -- ? )
+PRIVATE>
+
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
kernel.private math sequences threads.private ;
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 ;
: new-c-stream ( handle class -- c-stream )
BUILTIN: tuple ;
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: 2dip
DEFER: 3dip
BUILTIN: bignum ;
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: >bignum ( x -- n ) foldable
GENERIC: >integer ( x -- n ) foldable
sequences.private splitting strings strings.private ;
IN: math.parser
+<PRIVATE
+PRIMITIVE: (format-float) ( n format -- byte-array )
+PRIVATE>
+
: digit> ( ch -- n )
{
{ [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
system ;
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 )
[ all-instances ] dip filter ; inline
cached-effect
cache-counter ;
+PRIMITIVE: jit-compile ( quot -- )
+PRIMITIVE: quot-compiled? ( quot -- ? )
+PRIMITIVE: quotation-code ( quot -- start end )
+
<PRIVATE
+PRIMITIVE: array>quotation ( array -- quot )
: uncurry ( curry -- obj quot )
{ curry } declare dup 2 slot swap 3 slot ; inline
slots.private strings words ;
IN: slots
+<PRIVATE
+PRIMITIVE: set-slot ( value obj n -- )
+PRIMITIVE: slot ( obj m -- value )
+PRIVATE>
+
TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
BUILTIN: string { length array-capacity read-only initial: 0 } aux ;
+PRIMITIVE: <string> ( n ch -- string )
+PRIMITIVE: resize-string ( n str -- newstr )
+
<PRIVATE
+PRIMITIVE: set-string-nth-fast ( ch n string -- )
+PRIMITIVE: string-nth-fast ( n string -- ch )
: string-hashcode ( str -- n ) 3 slot ; inline
{ "]" "}" ";" ">>" } [ define-delimiter ] each
"PRIMITIVE:" [
- "Primitive definition is not supported" throw
+ current-vocab name>>
+ scan-word scan-effect ensure-primitive
] define-core-syntax
"CS{" [
math.parser namespaces sequences ;
IN: system
+PRIMITIVE: (exit) ( n -- * )
+PRIMITIVE: nano-count ( -- ns )
+
SINGLETONS: x86.32 x86.64 arm ppc.32 ppc.64 ;
UNION: x86 x86.32 x86.64 ;
{ def quotation initial: [ ] } props pic-def pic-tail-def
{ 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
! and parse-datum looks for things that are actually words instead of
! also looking for classes
M: primitive definer drop \ PRIMITIVE: 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 ;
: target-word ( word -- target )