steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Stack effect declarations are mandatory on all words now 

define-temp now takes an effect parameter
Fix compiler bug that Dan found
Stricter enforcement of * effects
Move compile-call from compiler.units to compiler
db4
Slava Pestov 2009-02-23 20:27:05 -06:00
parent 0c090699c2
commit 1951d739a0
47 changed files with 349 additions and 340 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/c-types/c-types.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting namespaces make parser sequences strings words assocs splitting
@ -275,7 +275,7 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- ) : if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline pick "void" = [ drop nip call ] [ nip call ] if ; inline
: primitive-types CONSTANT: primitive-types
{ {
"char" "uchar" "char" "uchar"
"short" "ushort" "short" "ushort"
@ -284,7 +284,7 @@ M: long-long-type box-return ( type -- )
"longlong" "ulonglong" "longlong" "ulonglong"
"float" "double" "float" "double"
"void*" "bool" "void*" "bool"
} ; }
[ [
<c-type> <c-type>

4
basis/checksums/openssl/openssl.factor
View File

@ -9,9 +9,9 @@ ERROR: unknown-digest name ;
TUPLE: openssl-checksum name ; TUPLE: openssl-checksum name ;
: openssl-md5 T{ openssl-checksum f "md5" } ; CONSTANT: openssl-md5 T{ openssl-checksum f "md5" }
: openssl-sha1 T{ openssl-checksum f "sha1" } ; CONSTANT: openssl-sha1 T{ openssl-checksum f "sha1" }
INSTANCE: openssl-checksum stream-checksum INSTANCE: openssl-checksum stream-checksum

6
basis/cocoa/application/application.factor
View File

@ -19,9 +19,9 @@ IN: cocoa.application
] curry assoc-each ] curry assoc-each
] keep ; ] keep ;
: NSApplicationDelegateReplySuccess 0 ; CONSTANT: NSApplicationDelegateReplySuccess 0
: NSApplicationDelegateReplyCancel 1 ; CONSTANT: NSApplicationDelegateReplyCancel 1
: NSApplicationDelegateReplyFailure 2 ; CONSTANT: NSApplicationDelegateReplyFailure 2
: with-autorelease-pool ( quot -- ) : with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline NSAutoreleasePool -> new slip -> release ; inline

4
basis/cocoa/dialogs/dialogs.factor
View File

@ -18,8 +18,8 @@ IN: cocoa.dialogs
dup 0 -> setCanChooseDirectories: dup 0 -> setCanChooseDirectories:
dup 0 -> setAllowsMultipleSelection: ; dup 0 -> setAllowsMultipleSelection: ;
: NSOKButton 1 ; CONSTANT: NSOKButton 1
: NSCancelButton 0 ; CONSTANT: NSCancelButton 0
: open-panel ( -- paths ) : open-panel ( -- paths )
<NSOpenPanel> <NSOpenPanel>

14
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math continuations combinators compiler compiler.alien stack-checker kernel
namespaces make parser quotations sequences strings words math namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 cocoa.runtime io macros memoize io.encodings.utf8 effects libc
effects libc libc.private parser lexer init core-foundation fry libc.private parser lexer init core-foundation fry generalizations
generalizations specialized-arrays.direct.alien call ; specialized-arrays.direct.alien call ;
IN: cocoa.messages IN: cocoa.messages
: make-sender ( method function -- quot ) : make-sender ( method function -- quot )
@ -14,7 +14,7 @@ IN: cocoa.messages
: sender-stub ( method function -- word ) : sender-stub ( method function -- word )
[ "( sender-stub )" f <word> dup ] 2dip [ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when over first large-struct? [ "_stret" append ] when
make-sender define ; make-sender dup infer define-declared ;
SYMBOL: message-senders SYMBOL: message-senders
SYMBOL: super-message-senders SYMBOL: super-message-senders

2
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -5,7 +5,7 @@ cocoa.classes cocoa.application sequences cocoa core-foundation
core-foundation.strings core-foundation.arrays ; core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ; CONSTANT: NSStringPboardType "NSStringPboardType"
: pasteboard-string? ( pasteboard -- ? ) : pasteboard-string? ( pasteboard -- ? )
NSStringPboardType swap -> types CF>string-array member? ; NSStringPboardType swap -> types CF>string-array member? ;

18
basis/cocoa/runtime/runtime.factor
View File

@ -21,15 +21,15 @@ C-STRUCT: objc-super
{ "id" "receiver" } { "id" "receiver" }
{ "Class" "class" } ; { "Class" "class" } ;
: CLS_CLASS HEX: 1 ; CONSTANT: CLS_CLASS HEX: 1
: CLS_META HEX: 2 ; CONSTANT: CLS_META HEX: 2
: CLS_INITIALIZED HEX: 4 ; CONSTANT: CLS_INITIALIZED HEX: 4
: CLS_POSING HEX: 8 ; CONSTANT: CLS_POSING HEX: 8
: CLS_MAPPED HEX: 10 ; CONSTANT: CLS_MAPPED HEX: 10
: CLS_FLUSH_CACHE HEX: 20 ; CONSTANT: CLS_FLUSH_CACHE HEX: 20
: CLS_GROW_CACHE HEX: 40 ; CONSTANT: CLS_GROW_CACHE HEX: 40
: CLS_NEED_BIND HEX: 80 ; CONSTANT: CLS_NEED_BIND HEX: 80
: CLS_METHOD_ARRAY HEX: 100 ; CONSTANT: CLS_METHOD_ARRAY HEX: 100
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;

6
basis/cocoa/subclassing/subclassing.factor
View File

@ -38,9 +38,9 @@ IN: cocoa.subclassing
] map concat ; ] map concat ;
: prepare-method ( ret types quot -- type imp ) : prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip [ [ [ encode-types ] 2keep ] dip
"cdecl" swap 4array % \ alien-callback , '[ _ _ "cdecl" _ alien-callback ]
] [ ] make define-temp ; (( -- callback )) define-temp ;
: prepare-methods ( methods -- methods ) : prepare-methods ( methods -- methods )
[ [

74
basis/cocoa/views/views.factor
View File

@ -5,43 +5,43 @@ cocoa cocoa.messages cocoa.classes cocoa.types sequences
continuations accessors ; continuations accessors ;
IN: cocoa.views IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ; CONSTANT: NSOpenGLPFAAllRenderers 1
: NSOpenGLPFADoubleBuffer 5 ; CONSTANT: NSOpenGLPFADoubleBuffer 5
: NSOpenGLPFAStereo 6 ; CONSTANT: NSOpenGLPFAStereo 6
: NSOpenGLPFAAuxBuffers 7 ; CONSTANT: NSOpenGLPFAAuxBuffers 7
: NSOpenGLPFAColorSize 8 ; CONSTANT: NSOpenGLPFAColorSize 8
: NSOpenGLPFAAlphaSize 11 ; CONSTANT: NSOpenGLPFAAlphaSize 11
: NSOpenGLPFADepthSize 12 ; CONSTANT: NSOpenGLPFADepthSize 12
: NSOpenGLPFAStencilSize 13 ; CONSTANT: NSOpenGLPFAStencilSize 13
: NSOpenGLPFAAccumSize 14 ; CONSTANT: NSOpenGLPFAAccumSize 14
: NSOpenGLPFAMinimumPolicy 51 ; CONSTANT: NSOpenGLPFAMinimumPolicy 51
: NSOpenGLPFAMaximumPolicy 52 ; CONSTANT: NSOpenGLPFAMaximumPolicy 52
: NSOpenGLPFAOffScreen 53 ; CONSTANT: NSOpenGLPFAOffScreen 53
: NSOpenGLPFAFullScreen 54 ; CONSTANT: NSOpenGLPFAFullScreen 54
: NSOpenGLPFASampleBuffers 55 ; CONSTANT: NSOpenGLPFASampleBuffers 55
: NSOpenGLPFASamples 56 ; CONSTANT: NSOpenGLPFASamples 56
: NSOpenGLPFAAuxDepthStencil 57 ; CONSTANT: NSOpenGLPFAAuxDepthStencil 57
: NSOpenGLPFAColorFloat 58 ; CONSTANT: NSOpenGLPFAColorFloat 58
: NSOpenGLPFAMultisample 59 ; CONSTANT: NSOpenGLPFAMultisample 59
: NSOpenGLPFASupersample 60 ; CONSTANT: NSOpenGLPFASupersample 60
: NSOpenGLPFASampleAlpha 61 ; CONSTANT: NSOpenGLPFASampleAlpha 61
: NSOpenGLPFARendererID 70 ; CONSTANT: NSOpenGLPFARendererID 70
: NSOpenGLPFASingleRenderer 71 ; CONSTANT: NSOpenGLPFASingleRenderer 71
: NSOpenGLPFANoRecovery 72 ; CONSTANT: NSOpenGLPFANoRecovery 72
: NSOpenGLPFAAccelerated 73 ; CONSTANT: NSOpenGLPFAAccelerated 73
: NSOpenGLPFAClosestPolicy 74 ; CONSTANT: NSOpenGLPFAClosestPolicy 74
: NSOpenGLPFARobust 75 ; CONSTANT: NSOpenGLPFARobust 75
: NSOpenGLPFABackingStore 76 ; CONSTANT: NSOpenGLPFABackingStore 76
: NSOpenGLPFAMPSafe 78 ; CONSTANT: NSOpenGLPFAMPSafe 78
: NSOpenGLPFAWindow 80 ; CONSTANT: NSOpenGLPFAWindow 80
: NSOpenGLPFAMultiScreen 81 ; CONSTANT: NSOpenGLPFAMultiScreen 81
: NSOpenGLPFACompliant 83 ; CONSTANT: NSOpenGLPFACompliant 83
: NSOpenGLPFAScreenMask 84 ; CONSTANT: NSOpenGLPFAScreenMask 84
: NSOpenGLPFAPixelBuffer 90 ; CONSTANT: NSOpenGLPFAPixelBuffer 90
: NSOpenGLPFAAllowOfflineRenderers 96 ; CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
: NSOpenGLPFAVirtualScreenCount 128 ; CONSTANT: NSOpenGLPFAVirtualScreenCount 128
: kCGLRendererGenericFloatID HEX: 00020400 ; CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
<PRIVATE <PRIVATE
@ -94,7 +94,7 @@ PRIVATE>
USE: opengl.gl USE: opengl.gl
USE: alien.syntax USE: alien.syntax
: NSOpenGLCPSwapInterval 222 ; CONSTANT: NSOpenGLCPSwapInterval 222
LIBRARY: OpenGL LIBRARY: OpenGL

9
basis/compiler/compiler-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax words io parser USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ; assocs words.private sequences compiler.units quotations ;
IN: compiler IN: compiler
HELP: enable-compiler HELP: enable-compiler
@ -16,6 +16,8 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
{ $subsection optimized-recompile-hook } { $subsection optimized-recompile-hook }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $subsection decompile }
"Compiling a single quotation:"
{ $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ; "Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
@ -48,3 +50,8 @@ HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } } { $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." } { $description "Compile a set of words." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: compile-call
{ $values { "quot" quotation } }
{ $description "Compiles and runs a quotation." }
{ $notes "This word is used by compiler unit tests to test compilation of small pieces of code." } ;

5
basis/compiler/compiler.factor
View File

@ -49,7 +49,7 @@ SYMBOL: +failed+
H{ } clone generic-dependencies set H{ } clone generic-dependencies set
f swap compiler-error ; f swap compiler-error ;
: fail ( word error -- ) : fail ( word error -- * )
[ swap compiler-error ] [ swap compiler-error ]
[ [
drop drop
@ -112,6 +112,9 @@ t compile-dependencies? set-global
: decompile ( word -- ) : decompile ( word -- )
f 2array 1array modify-code-heap ; f 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
: optimized-recompile-hook ( words -- alist ) : optimized-recompile-hook ( words -- alist )
[ [
<hashed-dlist> compile-queue set <hashed-dlist> compile-queue set

4
basis/compiler/tests/codegen.factor
View File

@ -51,7 +51,7 @@ unit-test
\ foo [ global >n get ndrop ] compile-call \ foo [ global >n get ndrop ] compile-call
] unit-test ] unit-test
: blech drop ; : blech ( x -- ) drop ;
[ 3 ] [ 3 ]
[ [
@ -102,7 +102,7 @@ unit-test
[ ] [ [ ] [
[ [
[ 200 dup [ 200 3array ] curry map drop ] times [ 200 dup [ 200 3array ] curry map drop ] times
] [ define-temp ] with-compilation-unit drop ] [ (( n -- )) define-temp ] with-compilation-unit drop
] unit-test ] unit-test
! Test how dispatch handles the end of a basic block ! Test how dispatch handles the end of a basic block

8
basis/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test quotations math kernel sequences USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units ; assocs namespaces make compiler.units compiler ;
IN: compiler.tests IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
@ -32,15 +32,15 @@ IN: compiler.tests
compile-call compile-call
] unit-test ] unit-test
: foobar ( quot -- ) : foobar ( quot: ( -- ) -- )
dup slip swap [ foobar ] [ drop ] if ; inline dup slip swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test [ ] [ [ [ f ] foobar ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test
: funky-assoc>map : funky-assoc>map ( assoc quot -- seq )
[ [
[ call f ] curry assoc-find 3drop [ call f ] curry assoc-find 3drop
] { } make ; inline ] { } make ; inline

2
basis/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tests IN: compiler.tests
USING: compiler.units kernel kernel.private memory math USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test

2
basis/compiler/tests/intrinsics.factor
View File

@ -5,7 +5,7 @@ strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii namespaces libc sequences.private io.encodings.ascii
classes ; classes compiler ;
IN: compiler.tests IN: compiler.tests
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.

9
basis/compiler/tests/optimizer.factor
View File

@ -3,7 +3,8 @@ stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep ; compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ;
IN: optimizer.tests IN: optimizer.tests
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
@ -208,14 +209,14 @@ USE: sorting
USE: binary-search USE: binary-search
USE: binary-search.private USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i ) : old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
dup length 1 <= [ dup length 1 <= [
from>> from>>
] [ ] [
[ midpoint swap call ] 3keep roll dup zero? [ midpoint swap call ] 3keep roll dup zero?
[ drop dup from>> swap midpoint@ + ] [ drop dup from>> swap midpoint@ + ]
[ dup midpoint@ cut-slice old-binsearch ] if [ drop dup midpoint@ head-slice old-binsearch ] if
] if ; inline ] if ; inline recursive
[ 10 ] [ [ 10 ] [
10 20 >vector <flat-slice> 10 20 >vector <flat-slice>

15
basis/compiler/tests/peg-regression-2.factor Normal file
View File

@ -0,0 +1,15 @@
IN: compiler.tests
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
M: string <times> ;
EBNF: parse-regexp
Times = .* => [[ "foo" ]]
Regexp = Times:t => [[ t <times> ]]
;EBNF
[ "foo" ] [ "a" parse-regexp ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -54,7 +54,7 @@ IN: compiler.tests
! Labels ! Labels
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline : recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive
[ ] [ t [ recursive-test ] compile-call ] unit-test [ ] [ t [ recursive-test ] compile-call ] unit-test

2
basis/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tests IN: compiler.tests
USING: kernel tools.test compiler.units ; USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ; TUPLE: color red green blue ;

4
basis/compiler/tree/comparisons/comparisons.factor
View File

@ -5,9 +5,9 @@ IN: compiler.tree.comparisons
! Some utilities for working with comparison operations. ! Some utilities for working with comparison operations.
: comparison-ops { < > <= >= } ; CONSTANT: comparison-ops { < > <= >= }
: generic-comparison-ops { before? after? before=? after=? } ; CONSTANT: generic-comparison-ops { before? after? before=? after=? }
: assumption ( i1 i2 op -- i3 ) : assumption ( i1 i2 op -- i3 )
{ {

28
basis/core-foundation/strings/strings.factor
View File

@ -7,20 +7,20 @@ IN: core-foundation.strings
TYPEDEF: void* CFStringRef TYPEDEF: void* CFStringRef
TYPEDEF: int CFStringEncoding TYPEDEF: int CFStringEncoding
: kCFStringEncodingMacRoman HEX: 0 ; CONSTANT: kCFStringEncodingMacRoman HEX: 0
: kCFStringEncodingWindowsLatin1 HEX: 0500 ; CONSTANT: kCFStringEncodingWindowsLatin1 HEX: 0500
: kCFStringEncodingISOLatin1 HEX: 0201 ; CONSTANT: kCFStringEncodingISOLatin1 HEX: 0201
: kCFStringEncodingNextStepLatin HEX: 0B01 ; CONSTANT: kCFStringEncodingNextStepLatin HEX: 0B01
: kCFStringEncodingASCII HEX: 0600 ; CONSTANT: kCFStringEncodingASCII HEX: 0600
: kCFStringEncodingUnicode HEX: 0100 ; CONSTANT: kCFStringEncodingUnicode HEX: 0100
: kCFStringEncodingUTF8 HEX: 08000100 ; CONSTANT: kCFStringEncodingUTF8 HEX: 08000100
: kCFStringEncodingNonLossyASCII HEX: 0BFF ; CONSTANT: kCFStringEncodingNonLossyASCII HEX: 0BFF
: kCFStringEncodingUTF16 HEX: 0100 ; CONSTANT: kCFStringEncodingUTF16 HEX: 0100
: kCFStringEncodingUTF16BE HEX: 10000100 ; CONSTANT: kCFStringEncodingUTF16BE HEX: 10000100
: kCFStringEncodingUTF16LE HEX: 14000100 ; CONSTANT: kCFStringEncodingUTF16LE HEX: 14000100
: kCFStringEncodingUTF32 HEX: 0c000100 ; CONSTANT: kCFStringEncodingUTF32 HEX: 0c000100
: kCFStringEncodingUTF32BE HEX: 18000100 ; CONSTANT: kCFStringEncodingUTF32BE HEX: 18000100
: kCFStringEncodingUTF32LE HEX: 1c000100 ; CONSTANT: kCFStringEncodingUTF32LE HEX: 1c000100
FUNCTION: CFStringRef CFStringCreateWithBytes ( FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc, CFAllocatorRef alloc,

4
basis/functors/functors.factor
View File

@ -80,9 +80,9 @@ M: object fake-quotations> ;
scan-param parsed scan-param parsed
\ add-mixin-instance parsed ; parsing \ add-mixin-instance parsed ; parsing
: `inline \ inline parsed ; parsing : `inline [ word make-inline ] over push-all ; parsing
: `parsing \ parsing parsed ; parsing : `parsing [ word make-parsing ] over push-all ; parsing
: `( : `(
")" parse-effect effect set ; parsing ")" parse-effect effect set ; parsing

2
basis/io/backend/unix/unix.factor
View File

@ -77,7 +77,7 @@ M: io-timeout summary drop "I/O operation timed out" ;
'[ handle>> _ wait-for-fd ] with-timeout ; '[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff ! Some general stuff
: file-mode OCT: 0666 ; CONSTANT: file-mode OCT: 0666
! Readers ! Readers
: (refill) ( port -- n ) : (refill) ( port -- n )

2
basis/none/none.factor
View File

@ -1,6 +1,6 @@
! Just a dummy shell for the -run switch... ! Just a dummy shell for the -run switch...
IN: none IN: none
: none ; : none ( -- ) ;
MAIN: none MAIN: none

294
basis/opengl/glu/glu.factor
View File

@ -11,183 +11,183 @@ TYPEDEF: void* GLubyte*
TYPEDEF: void* GLUfuncptr TYPEDEF: void* GLUfuncptr
! StringName ! StringName
: GLU_VERSION 100800 ; CONSTANT: GLU_VERSION 100800
: GLU_EXTENSIONS 100801 ; CONSTANT: GLU_EXTENSIONS 100801
! ErrorCode ! ErrorCode
: GLU_INVALID_ENUM 100900 ; CONSTANT: GLU_INVALID_ENUM 100900
: GLU_INVALID_VALUE 100901 ; CONSTANT: GLU_INVALID_VALUE 100901
: GLU_OUT_OF_MEMORY 100902 ; CONSTANT: GLU_OUT_OF_MEMORY 100902
: GLU_INCOMPATIBLE_GL_VERSION 100903 ; CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
: GLU_INVALID_OPERATION 100904 ; CONSTANT: GLU_INVALID_OPERATION 100904
! NurbsDisplay ! NurbsDisplay
: GLU_OUTLINE_POLYGON 100240 ; CONSTANT: GLU_OUTLINE_POLYGON 100240
: GLU_OUTLINE_PATCH 100241 ; CONSTANT: GLU_OUTLINE_PATCH 100241
! NurbsCallback ! NurbsCallback
: GLU_NURBS_ERROR 100103 ; CONSTANT: GLU_NURBS_ERROR 100103
: GLU_ERROR 100103 ; CONSTANT: GLU_ERROR 100103
: GLU_NURBS_BEGIN 100164 ; CONSTANT: GLU_NURBS_BEGIN 100164
: GLU_NURBS_BEGIN_EXT 100164 ; CONSTANT: GLU_NURBS_BEGIN_EXT 100164
: GLU_NURBS_VERTEX 100165 ; CONSTANT: GLU_NURBS_VERTEX 100165
: GLU_NURBS_VERTEX_EXT 100165 ; CONSTANT: GLU_NURBS_VERTEX_EXT 100165
: GLU_NURBS_NORMAL 100166 ; CONSTANT: GLU_NURBS_NORMAL 100166
: GLU_NURBS_NORMAL_EXT 100166 ; CONSTANT: GLU_NURBS_NORMAL_EXT 100166
: GLU_NURBS_COLOR 100167 ; CONSTANT: GLU_NURBS_COLOR 100167
: GLU_NURBS_COLOR_EXT 100167 ; CONSTANT: GLU_NURBS_COLOR_EXT 100167
: GLU_NURBS_TEXTURE_COORD 100168 ; CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
: GLU_NURBS_TEX_COORD_EXT 100168 ; CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
: GLU_NURBS_END 100169 ; CONSTANT: GLU_NURBS_END 100169
: GLU_NURBS_END_EXT 100169 ; CONSTANT: GLU_NURBS_END_EXT 100169
: GLU_NURBS_BEGIN_DATA 100170 ; CONSTANT: GLU_NURBS_BEGIN_DATA 100170
: GLU_NURBS_BEGIN_DATA_EXT 100170 ; CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
: GLU_NURBS_VERTEX_DATA 100171 ; CONSTANT: GLU_NURBS_VERTEX_DATA 100171
: GLU_NURBS_VERTEX_DATA_EXT 100171 ; CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
: GLU_NURBS_NORMAL_DATA 100172 ; CONSTANT: GLU_NURBS_NORMAL_DATA 100172
: GLU_NURBS_NORMAL_DATA_EXT 100172 ; CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
: GLU_NURBS_COLOR_DATA 100173 ; CONSTANT: GLU_NURBS_COLOR_DATA 100173
: GLU_NURBS_COLOR_DATA_EXT 100173 ; CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
: GLU_NURBS_TEXTURE_COORD_DATA 100174 ; CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
: GLU_NURBS_TEX_COORD_DATA_EXT 100174 ; CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
: GLU_NURBS_END_DATA 100175 ; CONSTANT: GLU_NURBS_END_DATA 100175
: GLU_NURBS_END_DATA_EXT 100175 ; CONSTANT: GLU_NURBS_END_DATA_EXT 100175
! NurbsError ! NurbsError
: GLU_NURBS_ERROR1 100251 ; CONSTANT: GLU_NURBS_ERROR1 100251
: GLU_NURBS_ERROR2 100252 ; CONSTANT: GLU_NURBS_ERROR2 100252
: GLU_NURBS_ERROR3 100253 ; CONSTANT: GLU_NURBS_ERROR3 100253
: GLU_NURBS_ERROR4 100254 ; CONSTANT: GLU_NURBS_ERROR4 100254
: GLU_NURBS_ERROR5 100255 ; CONSTANT: GLU_NURBS_ERROR5 100255
: GLU_NURBS_ERROR6 100256 ; CONSTANT: GLU_NURBS_ERROR6 100256
: GLU_NURBS_ERROR7 100257 ; CONSTANT: GLU_NURBS_ERROR7 100257
: GLU_NURBS_ERROR8 100258 ; CONSTANT: GLU_NURBS_ERROR8 100258
: GLU_NURBS_ERROR9 100259 ; CONSTANT: GLU_NURBS_ERROR9 100259
: GLU_NURBS_ERROR10 100260 ; CONSTANT: GLU_NURBS_ERROR10 100260
: GLU_NURBS_ERROR11 100261 ; CONSTANT: GLU_NURBS_ERROR11 100261
: GLU_NURBS_ERROR12 100262 ; CONSTANT: GLU_NURBS_ERROR12 100262
: GLU_NURBS_ERROR13 100263 ; CONSTANT: GLU_NURBS_ERROR13 100263
: GLU_NURBS_ERROR14 100264 ; CONSTANT: GLU_NURBS_ERROR14 100264
: GLU_NURBS_ERROR15 100265 ; CONSTANT: GLU_NURBS_ERROR15 100265
: GLU_NURBS_ERROR16 100266 ; CONSTANT: GLU_NURBS_ERROR16 100266
: GLU_NURBS_ERROR17 100267 ; CONSTANT: GLU_NURBS_ERROR17 100267
: GLU_NURBS_ERROR18 100268 ; CONSTANT: GLU_NURBS_ERROR18 100268
: GLU_NURBS_ERROR19 100269 ; CONSTANT: GLU_NURBS_ERROR19 100269
: GLU_NURBS_ERROR20 100270 ; CONSTANT: GLU_NURBS_ERROR20 100270
: GLU_NURBS_ERROR21 100271 ; CONSTANT: GLU_NURBS_ERROR21 100271
: GLU_NURBS_ERROR22 100272 ; CONSTANT: GLU_NURBS_ERROR22 100272
: GLU_NURBS_ERROR23 100273 ; CONSTANT: GLU_NURBS_ERROR23 100273
: GLU_NURBS_ERROR24 100274 ; CONSTANT: GLU_NURBS_ERROR24 100274
: GLU_NURBS_ERROR25 100275 ; CONSTANT: GLU_NURBS_ERROR25 100275
: GLU_NURBS_ERROR26 100276 ; CONSTANT: GLU_NURBS_ERROR26 100276
: GLU_NURBS_ERROR27 100277 ; CONSTANT: GLU_NURBS_ERROR27 100277
: GLU_NURBS_ERROR28 100278 ; CONSTANT: GLU_NURBS_ERROR28 100278
: GLU_NURBS_ERROR29 100279 ; CONSTANT: GLU_NURBS_ERROR29 100279
: GLU_NURBS_ERROR30 100280 ; CONSTANT: GLU_NURBS_ERROR30 100280
: GLU_NURBS_ERROR31 100281 ; CONSTANT: GLU_NURBS_ERROR31 100281
: GLU_NURBS_ERROR32 100282 ; CONSTANT: GLU_NURBS_ERROR32 100282
: GLU_NURBS_ERROR33 100283 ; CONSTANT: GLU_NURBS_ERROR33 100283
: GLU_NURBS_ERROR34 100284 ; CONSTANT: GLU_NURBS_ERROR34 100284
: GLU_NURBS_ERROR35 100285 ; CONSTANT: GLU_NURBS_ERROR35 100285
: GLU_NURBS_ERROR36 100286 ; CONSTANT: GLU_NURBS_ERROR36 100286
: GLU_NURBS_ERROR37 100287 ; CONSTANT: GLU_NURBS_ERROR37 100287
! NurbsProperty ! NurbsProperty
: GLU_AUTO_LOAD_MATRIX 100200 ; CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
: GLU_CULLING 100201 ; CONSTANT: GLU_CULLING 100201
: GLU_SAMPLING_TOLERANCE 100203 ; CONSTANT: GLU_SAMPLING_TOLERANCE 100203
: GLU_DISPLAY_MODE 100204 ; CONSTANT: GLU_DISPLAY_MODE 100204
: GLU_PARAMETRIC_TOLERANCE 100202 ; CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
: GLU_SAMPLING_METHOD 100205 ; CONSTANT: GLU_SAMPLING_METHOD 100205
: GLU_U_STEP 100206 ; CONSTANT: GLU_U_STEP 100206
: GLU_V_STEP 100207 ; CONSTANT: GLU_V_STEP 100207
: GLU_NURBS_MODE 100160 ; CONSTANT: GLU_NURBS_MODE 100160
: GLU_NURBS_MODE_EXT 100160 ; CONSTANT: GLU_NURBS_MODE_EXT 100160
: GLU_NURBS_TESSELLATOR 100161 ; CONSTANT: GLU_NURBS_TESSELLATOR 100161
: GLU_NURBS_TESSELLATOR_EXT 100161 ; CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
: GLU_NURBS_RENDERER 100162 ; CONSTANT: GLU_NURBS_RENDERER 100162
: GLU_NURBS_RENDERER_EXT 100162 ; CONSTANT: GLU_NURBS_RENDERER_EXT 100162
! NurbsSampling ! NurbsSampling
: GLU_OBJECT_PARAMETRIC_ERROR 100208 ; CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 ; CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
: GLU_OBJECT_PATH_LENGTH 100209 ; CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
: GLU_OBJECT_PATH_LENGTH_EXT 100209 ; CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
: GLU_PATH_LENGTH 100215 ; CONSTANT: GLU_PATH_LENGTH 100215
: GLU_PARAMETRIC_ERROR 100216 ; CONSTANT: GLU_PARAMETRIC_ERROR 100216
: GLU_DOMAIN_DISTANCE 100217 ; CONSTANT: GLU_DOMAIN_DISTANCE 100217
! NurbsTrim ! NurbsTrim
: GLU_MAP1_TRIM_2 100210 ; CONSTANT: GLU_MAP1_TRIM_2 100210
: GLU_MAP1_TRIM_3 100211 ; CONSTANT: GLU_MAP1_TRIM_3 100211
! QuadricDrawStyle ! QuadricDrawStyle
: GLU_POINT 100010 ; CONSTANT: GLU_POINT 100010
: GLU_LINE 100011 ; CONSTANT: GLU_LINE 100011
: GLU_FILL 100012 ; CONSTANT: GLU_FILL 100012
: GLU_SILHOUETTE 100013 ; CONSTANT: GLU_SILHOUETTE 100013
! QuadricNormal ! QuadricNormal
: GLU_SMOOTH 100000 ; CONSTANT: GLU_SMOOTH 100000
: GLU_FLAT 100001 ; CONSTANT: GLU_FLAT 100001
: GLU_NONE 100002 ; CONSTANT: GLU_NONE 100002
! QuadricOrientation ! QuadricOrientation
: GLU_OUTSIDE 100020 ; CONSTANT: GLU_OUTSIDE 100020
: GLU_INSIDE 100021 ; CONSTANT: GLU_INSIDE 100021
! TessCallback ! TessCallback
: GLU_TESS_BEGIN 100100 ; CONSTANT: GLU_TESS_BEGIN 100100
: GLU_BEGIN 100100 ; CONSTANT: GLU_BEGIN 100100
: GLU_TESS_VERTEX 100101 ; CONSTANT: GLU_TESS_VERTEX 100101
: GLU_VERTEX 100101 ; CONSTANT: GLU_VERTEX 100101
: GLU_TESS_END 100102 ; CONSTANT: GLU_TESS_END 100102
: GLU_END 100102 ; CONSTANT: GLU_END 100102
: GLU_TESS_ERROR 100103 ; CONSTANT: GLU_TESS_ERROR 100103
: GLU_TESS_EDGE_FLAG 100104 ; CONSTANT: GLU_TESS_EDGE_FLAG 100104
: GLU_EDGE_FLAG 100104 ; CONSTANT: GLU_EDGE_FLAG 100104
: GLU_TESS_COMBINE 100105 ; CONSTANT: GLU_TESS_COMBINE 100105
: GLU_TESS_BEGIN_DATA 100106 ; CONSTANT: GLU_TESS_BEGIN_DATA 100106
: GLU_TESS_VERTEX_DATA 100107 ; CONSTANT: GLU_TESS_VERTEX_DATA 100107
: GLU_TESS_END_DATA 100108 ; CONSTANT: GLU_TESS_END_DATA 100108
: GLU_TESS_ERROR_DATA 100109 ; CONSTANT: GLU_TESS_ERROR_DATA 100109
: GLU_TESS_EDGE_FLAG_DATA 100110 ; CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
: GLU_TESS_COMBINE_DATA 100111 ; CONSTANT: GLU_TESS_COMBINE_DATA 100111
! TessContour ! TessContour
: GLU_CW 100120 ; CONSTANT: GLU_CW 100120
: GLU_CCW 100121 ; CONSTANT: GLU_CCW 100121
: GLU_INTERIOR 100122 ; CONSTANT: GLU_INTERIOR 100122
: GLU_EXTERIOR 100123 ; CONSTANT: GLU_EXTERIOR 100123
: GLU_UNKNOWN 100124 ; CONSTANT: GLU_UNKNOWN 100124
! TessProperty ! TessProperty
: GLU_TESS_WINDING_RULE 100140 ; CONSTANT: GLU_TESS_WINDING_RULE 100140
: GLU_TESS_BOUNDARY_ONLY 100141 ; CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
: GLU_TESS_TOLERANCE 100142 ; CONSTANT: GLU_TESS_TOLERANCE 100142
! TessError ! TessError
: GLU_TESS_ERROR1 100151 ; CONSTANT: GLU_TESS_ERROR1 100151
: GLU_TESS_ERROR2 100152 ; CONSTANT: GLU_TESS_ERROR2 100152
: GLU_TESS_ERROR3 100153 ; CONSTANT: GLU_TESS_ERROR3 100153
: GLU_TESS_ERROR4 100154 ; CONSTANT: GLU_TESS_ERROR4 100154
: GLU_TESS_ERROR5 100155 ; CONSTANT: GLU_TESS_ERROR5 100155
: GLU_TESS_ERROR6 100156 ; CONSTANT: GLU_TESS_ERROR6 100156
: GLU_TESS_ERROR7 100157 ; CONSTANT: GLU_TESS_ERROR7 100157
: GLU_TESS_ERROR8 100158 ; CONSTANT: GLU_TESS_ERROR8 100158
: GLU_TESS_MISSING_BEGIN_POLYGON 100151 ; CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 ; CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
: GLU_TESS_MISSING_END_POLYGON 100153 ; CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
: GLU_TESS_MISSING_END_CONTOUR 100154 ; CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
: GLU_TESS_COORD_TOO_LARGE 100155 ; CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ; CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
! TessWinding ! TessWinding
: GLU_TESS_WINDING_ODD 100130 ; CONSTANT: GLU_TESS_WINDING_ODD 100130
: GLU_TESS_WINDING_NONZERO 100131 ; CONSTANT: GLU_TESS_WINDING_NONZERO 100131
: GLU_TESS_WINDING_POSITIVE 100132 ; CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
: GLU_TESS_WINDING_NEGATIVE 100133 ; CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 ; CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
LIBRARY: glu LIBRARY: glu

2
basis/openssl/libcrypto/libcrypto.factor
View File

@ -99,7 +99,7 @@ FUNCTION: void* BIO_f_buffer ( ) ;
! evp.h ! evp.h
! =============================================== ! ===============================================
: EVP_MAX_MD_SIZE 64 ; CONSTANT: EVP_MAX_MD_SIZE 64
C-STRUCT: EVP_MD_CTX C-STRUCT: EVP_MD_CTX
{ "EVP_MD*" "digest" } { "EVP_MD*" "digest" }

4
basis/peg/parsers/parsers.factor
View File

@ -7,12 +7,12 @@ IN: peg.parsers
TUPLE: just-parser p1 ; TUPLE: just-parser p1 ;
: just-pattern CONSTANT: just-pattern
[ [
execute dup [ execute dup [
dup remaining>> empty? [ drop f ] unless dup remaining>> empty? [ drop f ] unless
] when ] when
] ; ]
M: just-parser (compile) ( parser -- quot ) M: just-parser (compile) ( parser -- quot )

48
basis/stack-checker/backend/backend.factor
View File

@ -124,18 +124,13 @@ M: object apply-object push-literal ;
: undo-infer ( -- ) : undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ; recorded get [ f "inferred-effect" set-word-prop ] each ;
: consume/produce ( effect quot -- ) : (consume/produce) ( effect -- inputs outputs )
#! quot is ( inputs outputs -- ) [ in>> length consume-d ] [ out>> length produce-d ] bi ;
[
[ : consume/produce ( effect quot: ( inputs outputs -- ) -- )
[ in>> length consume-d ] '[ (consume/produce) @ ]
[ out>> length produce-d ] [ terminated?>> [ terminate ] when ]
bi bi ; inline
] dip call
] [
drop
terminated?>> [ terminate ] when
] 2bi ; inline
: infer-word-def ( word -- ) : infer-word-def ( word -- )
[ specialized-def ] [ add-recursive-state ] bi infer-quot ; [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
@ -143,23 +138,12 @@ M: object apply-object push-literal ;
: end-infer ( -- ) : end-infer ( -- )
meta-d clone #return, ; meta-d clone #return, ;
: effect-required? ( word -- ? ) : required-stack-effect ( word -- effect )
{ dup stack-effect [ ] [ missing-effect inference-error ] ?if ;
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ def>> [ word? ] any? ]
} cond ;
: ?missing-effect ( word -- )
dup effect-required?
[ missing-effect inference-error ] [ drop ] if ;
: check-effect ( word effect -- ) : check-effect ( word effect -- )
over stack-effect { over required-stack-effect 2dup effect<=
{ [ dup not ] [ 2drop ?missing-effect ] } [ 3drop ] [ effect-error ] if ;
{ [ 2dup effect<= ] [ 3drop ] }
[ effect-error ]
} cond ;
: finish-word ( word -- ) : finish-word ( word -- )
current-effect current-effect
@ -183,22 +167,20 @@ M: object apply-object push-literal ;
dependencies off dependencies off
generic-dependencies off generic-dependencies off
[ infer-word-def end-infer ] [ infer-word-def end-infer ]
[ finish-word current-effect ] [ finish-word ]
bi [ stack-effect ]
tri
] with-scope ] with-scope
] maybe-cannot-infer ; ] maybe-cannot-infer ;
: apply-word/effect ( word effect -- ) : apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ; swap '[ _ #call, ] consume/produce ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
: call-recursive-word ( word -- ) : call-recursive-word ( word -- )
dup required-stack-effect apply-word/effect ; dup required-stack-effect apply-word/effect ;
: cached-infer ( word -- ) : cached-infer ( word -- )
dup "inferred-effect" word-prop apply-word/effect ; dup stack-effect apply-word/effect ;
: with-infer ( quot -- effect visitor ) : with-infer ( quot -- effect visitor )
[ [

6
basis/stack-checker/known-words/known-words.factor
View File

@ -319,12 +319,18 @@ M: object infer-call*
\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i { fixnum fixnum } { integer } define-primitive
\ fixnum/i make-foldable \ fixnum/i make-foldable
\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive
\ fixnum/i-fast make-foldable
\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
\ fixnum-mod make-foldable \ fixnum-mod make-foldable
\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
\ fixnum/mod make-foldable \ fixnum/mod make-foldable
\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive
\ fixnum/mod-fast make-foldable
\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
\ fixnum-bitand make-foldable \ fixnum-bitand make-foldable

2
basis/threads/threads.factor
View File

@ -118,7 +118,7 @@ DEFER: stop
[ ] while [ ] while
drop ; drop ;
: start ( namestack thread -- ) : start ( namestack thread -- * )
[ [
set-self set-self
set-namestack set-namestack

8
basis/tools/deploy/config/config.factor
View File

@ -14,12 +14,12 @@ SYMBOL: deploy-threads?
SYMBOL: deploy-io SYMBOL: deploy-io
: deploy-io-options CONSTANT: deploy-io-options
{ {
{ 1 "Level 1 - No input/output" } { 1 "Level 1 - No input/output" }
{ 2 "Level 2 - Basic ANSI C streams" } { 2 "Level 2 - Basic ANSI C streams" }
{ 3 "Level 3 - Non-blocking streams and networking" } { 3 "Level 3 - Non-blocking streams and networking" }
} ; }
: strip-io? ( -- ? ) deploy-io get 1 = ; : strip-io? ( -- ? ) deploy-io get 1 = ;
@ -27,7 +27,7 @@ SYMBOL: deploy-io
SYMBOL: deploy-reflection SYMBOL: deploy-reflection
: deploy-reflection-options CONSTANT: deploy-reflection-options
{ {
{ 1 "Level 1 - No reflection" } { 1 "Level 1 - No reflection" }
{ 2 "Level 2 - Retain word names" } { 2 "Level 2 - Retain word names" }
@ -35,7 +35,7 @@ SYMBOL: deploy-reflection
{ 4 "Level 4 - Debugger" } { 4 "Level 4 - Debugger" }
{ 5 "Level 5 - Parser" } { 5 "Level 5 - Parser" }
{ 6 "Level 6 - Full environment" } { 6 "Level 6 - Full environment" }
} ; }
: strip-word-names? ( -- ? ) deploy-reflection get 2 < ; : strip-word-names? ( -- ? ) deploy-reflection get 2 < ;
: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ; : strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ;

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -190,7 +190,7 @@ IN: tools.deploy.shaker
"Stripping default methods" show "Stripping default methods" show
[ [
[ generic? ] instances [ generic? ] instances
[ "No method" throw ] define-temp [ "No method" throw ] (( -- * )) define-temp
dup t "default" set-word-prop dup t "default" set-word-prop
'[ '[
[ _ "default-method" set-word-prop ] [ make-generic ] bi [ _ "default-method" set-word-prop ] [ make-generic ] bi

8
basis/ui/cocoa/views/views.factor
View File

@ -14,15 +14,15 @@ IN: ui.cocoa.views
#! Cocoa -> Factor UI button mapping #! Cocoa -> Factor UI button mapping
-> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ; -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
: modifiers CONSTANT: modifiers
{ {
{ S+ HEX: 20000 } { S+ HEX: 20000 }
{ C+ HEX: 40000 } { C+ HEX: 40000 }
{ A+ HEX: 100000 } { A+ HEX: 100000 }
{ M+ HEX: 80000 } { M+ HEX: 80000 }
} ; }
: key-codes CONSTANT: key-codes
H{ H{
{ 71 "CLEAR" } { 71 "CLEAR" }
{ 36 "RET" } { 36 "RET" }
@ -47,7 +47,7 @@ IN: ui.cocoa.views
{ 126 "UP" } { 126 "UP" }
{ 116 "PAGE_UP" } { 116 "PAGE_UP" }
{ 121 "PAGE_DOWN" } { 121 "PAGE_DOWN" }
} ; }
: key-code ( event -- string ? ) : key-code ( event -- string ? )
dup -> keyCode key-codes at dup -> keyCode key-codes at

2
basis/ui/gadgets/buttons/buttons.factor
View File

@ -173,7 +173,7 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
<PRIVATE <PRIVATE
: circle-steps 8 ; CONSTANT: circle-steps 8
PRIVATE> PRIVATE>

18
basis/ui/gadgets/frames/frames.factor
View File

@ -13,16 +13,16 @@ M: glue pref-dim* drop { 0 0 } ;
: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ; : <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
: @center 1 1 ; inline : @center ( -- i j ) 1 1 ; inline
: @left 0 1 ; inline : @left ( -- i j ) 0 1 ; inline
: @right 2 1 ; inline : @right ( -- i j ) 2 1 ; inline
: @top 1 0 ; inline : @top ( -- i j ) 1 0 ; inline
: @bottom 1 2 ; inline : @bottom ( -- i j ) 1 2 ; inline
: @top-left 0 0 ; inline : @top-left ( -- i j ) 0 0 ; inline
: @top-right 2 0 ; inline : @top-right ( -- i j ) 2 0 ; inline
: @bottom-left 0 2 ; inline : @bottom-left ( -- i j ) 0 2 ; inline
: @bottom-right 2 2 ; inline : @bottom-right ( -- i j ) 2 2 ; inline
TUPLE: frame < grid ; TUPLE: frame < grid ;

2
basis/ui/gadgets/sliders/sliders.factor
View File

@ -18,7 +18,7 @@ TUPLE: slider < frame elevator thumb saved line ;
: elevator-length ( slider -- n ) : elevator-length ( slider -- n )
[ elevator>> dim>> ] [ orientation>> ] bi v. ; [ elevator>> dim>> ] [ orientation>> ] bi v. ;
: min-thumb-dim 15 ; CONSTANT: min-thumb-dim 15
: slider-value ( gadget -- n ) model>> range-value >fixnum ; : slider-value ( gadget -- n ) model>> range-value >fixnum ;
: slider-page ( gadget -- n ) model>> range-page-value ; : slider-page ( gadget -- n ) model>> range-page-value ;

4
basis/ui/gadgets/theme/theme.factor
View File

@ -56,6 +56,6 @@ IN: ui.gadgets.theme
T{ gray f 0.5 1.0 } T{ gray f 0.5 1.0 }
} <gradient> ; } <gradient> ;
: sans-serif-font { "sans-serif" plain 12 } ; CONSTANT: sans-serif-font { "sans-serif" plain 12 }
: monospace-font { "monospace" plain 12 } ; CONSTANT: monospace-font { "monospace" plain 12 }

10
basis/ui/render/render.factor
View File

@ -191,11 +191,11 @@ M: polygon draw-interior
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ] [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
tri ; tri ;
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ; CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } }
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ; CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ; CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } }
: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ; CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } }
: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ; CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
: <polygon-gadget> ( color points -- gadget ) : <polygon-gadget> ( color points -- gadget )
dup max-dim dup max-dim

8
basis/unicode/data/data.factor
View File

@ -97,8 +97,8 @@ VALUE: properties
[ nip zero? not ] assoc-filter [ nip zero? not ] assoc-filter
>hashtable ; >hashtable ;
: categories ( -- names ) ! For non-existent characters, use Cn
! For non-existent characters, use Cn CONSTANT: categories
{ "Cn" { "Cn"
"Lu" "Ll" "Lt" "Lm" "Lo" "Lu" "Ll" "Lt" "Lm" "Lo"
"Mn" "Mc" "Me" "Mn" "Mc" "Me"
@ -106,9 +106,9 @@ VALUE: properties
"Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
"Sm" "Sc" "Sk" "So" "Sm" "Sc" "Sk" "So"
"Zs" "Zl" "Zp" "Zs" "Zl" "Zp"
"Cc" "Cf" "Cs" "Co" } ; "Cc" "Cf" "Cs" "Co" }
: num-chars HEX: 2FA1E ; CONSTANT: num-chars HEX: 2FA1E
! the maximum unicode char in the first 3 planes ! the maximum unicode char in the first 3 planes

2
core/bootstrap/primitives.factor
View File

@ -538,4 +538,4 @@ tuple
[ [ first2 ] dip make-primitive ] each-index [ [ first2 ] dip make-primitive ] each-index
! Bump build number ! Bump build number
"build" "kernel" create build 1+ 1quotation define "build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared

4
core/compiler/units/units-docs.factor
View File

@ -67,7 +67,3 @@ HELP: modify-code-heap ( alist -- )
HELP: compile HELP: compile
{ $values { "words" "a sequence of words" } } { $values { "words" "a sequence of words" } }
{ $description "Compiles a set of words." } ; { $description "Compiles a set of words." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } ;

3
core/compiler/units/units.factor
View File

@ -172,9 +172,6 @@ SYMBOL: remake-generics-hook
] [ ] cleanup ] [ ] cleanup
] with-scope ; inline ] with-scope ; inline
: compile-call ( quot -- )
[ define-temp ] with-compilation-unit execute ;
: default-recompile-hook ( words -- alist ) : default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ; [ f ] { } map>assoc ;

8
core/continuations/continuations.factor
View File

@ -92,10 +92,10 @@ C: <continuation> continuation
PRIVATE> PRIVATE>
: continue-with ( obj continuation -- ) : continue-with ( obj continuation -- * )
[ (continue-with) ] 2 (throw) ; [ (continue-with) ] 2 (throw) ;
: continue ( continuation -- ) : continue ( continuation -- * )
f swap continue-with ; f swap continue-with ;
SYMBOL: return-continuation SYMBOL: return-continuation
@ -103,7 +103,7 @@ SYMBOL: return-continuation
: with-return ( quot -- ) : with-return ( quot -- )
[ [ return-continuation set ] prepose callcc0 ] with-scope ; inline [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
: return ( -- ) : return ( -- * )
return-continuation get continue ; return-continuation get continue ;
: with-datastack ( stack quot -- newstack ) : with-datastack ( stack quot -- newstack )
@ -173,7 +173,7 @@ TUPLE: restart name obj continuation ;
C: <restart> restart C: <restart> restart
: restart ( restart -- ) : restart ( restart -- * )
[ obj>> ] [ continuation>> ] bi continue-with ; [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ; M: object compute-restarts drop { } ;

2
core/effects/effects.factor
View File

@ -48,6 +48,8 @@ M: word stack-effect
{ "declared-effect" "inferred-effect" } { "declared-effect" "inferred-effect" }
swap props>> [ at ] curry map [ ] find nip ; swap props>> [ at ] curry map [ ] find nip ;
M: deferred stack-effect call-next-method (( -- * )) or ;
M: effect clone M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ; [ in>> clone ] [ out>> clone ] bi <effect> ;

12
core/generic/standard/standard.factor
View File

@ -50,16 +50,16 @@ ERROR: no-method object generic ;
convert-hi-tag-methods convert-hi-tag-methods
<lo-tag-dispatch-engine> ; <lo-tag-dispatch-engine> ;
: mangle-method ( method -- quot )
1quotation generic get extra-values \ drop <repetition>
prepend [ ] like ;
: find-default ( methods -- quot ) : find-default ( methods -- quot )
#! Side-effects methods. #! Side-effects methods.
object bootstrap-word swap delete-at* [ object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation drop generic get "default-method" word-prop mangle-method
] unless ; ] unless ;
: mangle-method ( method generic -- quot )
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
: <standard-engine> ( word -- engine ) : <standard-engine> ( word -- engine )
object bootstrap-word assumed set { object bootstrap-word assumed set {
[ generic set ] [ generic set ]
@ -67,7 +67,7 @@ ERROR: no-method object generic ;
[ V{ } clone "engines" set-word-prop ] [ V{ } clone "engines" set-word-prop ]
[ [
"methods" word-prop "methods" word-prop
[ generic get mangle-method ] assoc-map [ mangle-method ] assoc-map
[ find-default default set ] [ find-default default set ]
[ <big-dispatch-engine> ] [ <big-dispatch-engine> ]
bi bi

4
core/words/words-docs.factor
View File

@ -288,12 +288,12 @@ HELP: define-declared
{ $side-effects "word" } ; { $side-effects "word" } ;
HELP: define-temp HELP: define-temp
{ $values { "quot" quotation } { "word" word } } { $values { "quot" quotation } { "effect" effect } { "word" word } }
{ $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." } { $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." }
{ $notes { $notes
"The following phrases are equivalent:" "The following phrases are equivalent:"
{ $code "[ 2 2 + . ] call" } { $code "[ 2 2 + . ] call" }
{ $code "[ 2 2 + . ] define-temp execute" } { $code "[ 2 2 + . ] (( -- )) define-temp execute" }
"This word must be called from inside " { $link with-compilation-unit } "." "This word must be called from inside " { $link with-compilation-unit } "."
} ; } ;

4
core/words/words.factor
View File

@ -212,8 +212,8 @@ M: word subwords drop f ;
: gensym ( -- word ) : gensym ( -- word )
"( gensym )" f <word> ; "( gensym )" f <word> ;
: define-temp ( quot -- word ) : define-temp ( quot effect -- word )
[ gensym dup ] dip define ; [ gensym dup ] 2dip define-declared ;
: reveal ( word -- ) : reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words dup [ name>> ] [ vocabulary>> ] bi dup vocab-words