primitives: Change PRIMITIVE: to check that the word is in that vocabulary and the stack effect is correct.

Use PRIMITIVE: in core/ and basis/

basis/alien/libraries/libraries.factor

@@ -5,6 +5,12 @@ kernel namespaces destructors sequences strings
 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) ;

basis/locals/backend/backend.factor

@@ -3,6 +3,11 @@
 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

basis/threads/threads.factor

@@ -9,6 +9,15 @@ FROM: assocs => change-at ;
 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

basis/tools/dispatch/dispatch.factor

@@ -4,6 +4,11 @@ USING: accessors kernel namespaces prettyprint classes.struct
 vm tools.dispatch.private ;
 IN: tools.dispatch
 
+<PRIVATE
+PRIMITIVE: dispatch-stats ( -- stats )
+PRIMITIVE: reset-dispatch-stats ( -- )
+PRIVATE>
+
 SYMBOL: last-dispatch-stats
 
 : dispatch-stats. ( -- )

basis/tools/memory/memory.factor

@@ -9,6 +9,12 @@ splitting strings system vm words hints hashtables ;
 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 ] [

basis/tools/profiler/sampling/sampling.factor

@@ -8,6 +8,12 @@ FROM: sequences => change-nth ;
 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

core/alien/accessors/accessors.factor

@@ -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 -- )

core/alien/alien.factor

@@ -8,6 +8,15 @@ IN: alien
 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 ;

core/arrays/arrays.factor

@@ -5,6 +5,9 @@ IN: arrays
 
 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

core/byte-arrays/byte-arrays.factor

@@ -7,6 +7,10 @@ IN: byte-arrays
 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

core/classes/tuple/tuple.factor

@@ -7,6 +7,11 @@ make math math.private memory namespaces quotations sequences
 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? ;
 

core/compiler/units/units.factor

@@ -8,6 +8,8 @@ FROM: namespaces => set ;
 FROM: sets => members ;
 IN: compiler.units
 
+PRIMITIVE: modify-code-heap ( alist update-existing? reset-pics? -- )
+
 SYMBOL: old-definitions
 SYMBOL: new-definitions
 

core/generic/single/single.factor

@@ -7,6 +7,14 @@ sequences words ;
 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 ;

core/io/files/files.factor

@@ -5,6 +5,10 @@ io.encodings io.encodings.utf8 io.files.private io.pathnames
 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+

core/io/streams/c/c.factor

@@ -5,6 +5,16 @@ destructors io io.backend io.encodings.utf8 io.files kernel
 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 )

core/kernel/kernel.factor

@@ -7,6 +7,65 @@ BUILTIN: callstack ;
 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

core/math/math.factor

@@ -7,6 +7,74 @@ BUILTIN: fixnum ;
 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

core/math/parser/parser.factor

@@ -5,6 +5,10 @@ layouts make math math.private namespaces sbufs sequences
 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 ] }

core/memory/memory.factor

@@ -4,6 +4,17 @@ USING: alien.strings io.backend kernel memory.private sequences
 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
 

core/quotations/quotations.factor

@@ -9,7 +9,12 @@ BUILTIN: quotation
     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

core/slots/slots.factor

@@ -7,6 +7,11 @@ kernel.private make math quotations sequences sequences.private
 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 ;

core/strings/strings.factor

@@ -7,7 +7,12 @@ IN: strings
 
 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
 

core/syntax/syntax.factor

@@ -31,7 +31,8 @@ IN: bootstrap.syntax
     { "]" "}" ";" ">>" } [ define-delimiter ] each
 
     "PRIMITIVE:" [
-        "Primitive definition is not supported" throw
+        current-vocab name>>
+        scan-word scan-effect ensure-primitive
     ] define-core-syntax
 
     "CS{" [

core/system/system.factor

@@ -4,6 +4,9 @@ USING: assocs continuations init io kernel kernel.private make
 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 ;

core/words/words.factor

@@ -11,6 +11,13 @@ BUILTIN: word
 { 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
@@ -68,6 +75,14 @@ PREDICATE: primitive < word "primitive" word-prop ;
 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 )