From 2dcbd5b3db15e16464f4057dc5578900216dd056 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 22 Feb 2009 21:26:16 -0600 Subject: [PATCH 01/14] fix docs for a word --- core/io/encodings/encodings-docs.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 509757c68a..e13e05bf40 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io quotations ; +USING: help.markup help.syntax io quotations math ; IN: io.encodings HELP: @@ -71,6 +71,9 @@ HELP: with-encoded-output { $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ; HELP: replacement-char +{ $values + { "value" integer } +} { $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ; ARTICLE: "encodings-descriptors" "Encoding descriptors" From a4817a0e1712f0b1c521dc3a22de84f45493398c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 23 Feb 2009 08:37:38 -0600 Subject: [PATCH 02/14] dont run postgresql tests on win64 --- basis/db/errors/postgresql/postgresql-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/db/errors/postgresql/postgresql-tests.factor b/basis/db/errors/postgresql/postgresql-tests.factor index 9dbebe0712..f6668031e5 100644 --- a/basis/db/errors/postgresql/postgresql-tests.factor +++ b/basis/db/errors/postgresql/postgresql-tests.factor @@ -5,7 +5,7 @@ db.errors.postgresql db.postgresql io.files.unique kernel namespaces tools.test db.tester continuations ; IN: db.errors.postgresql.tests -postgresql-test-db [ +[ [ "drop table foo;" sql-command ] ignore-errors [ "drop table ship;" sql-command ] ignore-errors @@ -29,4 +29,4 @@ postgresql-test-db [ sql-syntax-error? ] must-fail-with -] with-db +] test-postgresql From c3ef25f81c1a8b0a11b8ad5ac5c214f482a30dfd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 23 Feb 2009 10:35:42 -0600 Subject: [PATCH 03/14] made editors.emacs load windows file on windows --- basis/editors/emacs/emacs.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index fa717a70fa..05b879770e 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -1,6 +1,6 @@ USING: definitions io.launcher kernel parser words sequences math math.parser namespaces editors make system combinators.short-circuit -fry threads ; +fry threads vocabs.loader ; IN: editors.emacs SYMBOL: emacsclient-path @@ -22,3 +22,5 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; where first2 emacsclient ; [ emacsclient ] edit-hook set-global + +os windows? [ "editors.emacs.windows" require ] when From ea851e3a3281db27f60ef3b1653738147435f7e4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 23 Feb 2009 16:47:07 -0600 Subject: [PATCH 04/14] refactor cairo-demo a bit --- extra/cairo-demo/cairo-demo.factor | 66 +++++++++++++++++------------- 1 file changed, 38 insertions(+), 28 deletions(-) diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor index cec6702ce0..29eb5f4986 100644 --- a/extra/cairo-demo/cairo-demo.factor +++ b/extra/cairo-demo/cairo-demo.factor @@ -7,17 +7,16 @@ USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render - ui.gadgets opengl.gl accessors ; +combinators ui.gadgets opengl.gl accessors ; IN: cairo-demo - : make-image-array ( -- array ) - 384 256 4 * * ; + 384 256 4 * * ; : convert-array-to-surface ( array -- cairo_surface_t ) - CAIRO_FORMAT_ARGB32 384 256 over 4 * - cairo_image_surface_create_for_data ; + CAIRO_FORMAT_ARGB32 384 256 over 4 * + cairo_image_surface_create_for_data ; TUPLE: cairo-demo-gadget < gadget image-array cairo-t ; @@ -33,41 +32,52 @@ M: cairo-demo-gadget draw-gadget* ( gadget -- ) convert-array-to-surface ; : init-cairo ( gadget -- cairo_t ) - create-surface cairo_create ; + create-surface cairo_create ; M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ; +ERROR: no-cairo-t ; + +> - dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face - dup 90.0 cairo_set_font_size - dup 10.0 135.0 cairo_move_to - dup "Hello" cairo_show_text - dup 70.0 165.0 cairo_move_to - dup "World" cairo_text_path - dup 0.5 0.5 1 cairo_set_source_rgb - dup cairo_fill_preserve - dup 0 0 0 cairo_set_source_rgb - dup 2.56 cairo_set_line_width - dup cairo_stroke - dup 1 0.2 0.2 0.6 cairo_set_source_rgba - dup 10.0 135.0 5.12 0 pi 2 * cairo_arc - dup cairo_close_path - dup 70.0 165.0 5.12 0 pi 2 * cairo_arc - cairo_fill ; + cairo-t>> [ no-cairo-t ] unless* + { + [ + "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD + cairo_select_font_face + ] + [ 90.0 cairo_set_font_size ] + [ 10.0 135.0 cairo_move_to ] + [ "Hello" cairo_show_text ] + [ 70.0 165.0 cairo_move_to ] + [ "World" cairo_text_path ] + [ 0.5 0.5 1 cairo_set_source_rgb ] + [ cairo_fill_preserve ] + [ 0 0 0 cairo_set_source_rgb ] + [ 2.56 cairo_set_line_width ] + [ cairo_stroke ] + [ 1 0.2 0.2 0.6 cairo_set_source_rgba ] + [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ] + [ cairo_close_path ] + [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ] + [ cairo_fill ] + } cleave ; + +PRIVATE> M: cairo-demo-gadget graft* ( gadget -- ) - dup dup init-cairo swap (>>cairo-t) draw-hello-world ; + dup dup init-cairo swap (>>cairo-t) draw-hello-world ; M: cairo-demo-gadget ungraft* ( gadget -- ) - cairo-t>> cairo_destroy ; + cairo-t>> cairo_destroy ; : ( -- gadget ) - cairo-demo-gadget new-gadget ; + cairo-demo-gadget new-gadget ; : run ( -- ) - [ + [ "Hello World from Factor!" open-window - ] with-ui ; + ] with-ui ; MAIN: run From f32f94c763a5192f94a4a04d6b6f134b75807722 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 23 Feb 2009 16:53:05 -0600 Subject: [PATCH 05/14] fix cairo-demo drawing --- extra/cairo-demo/cairo-demo.factor | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor index 29eb5f4986..da744e1d53 100644 --- a/extra/cairo-demo/cairo-demo.factor +++ b/extra/cairo-demo/cairo-demo.factor @@ -6,8 +6,9 @@ ! http://cairographics.org/samples/text/ -USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render -combinators ui.gadgets opengl.gl accessors ; +USING: cairo.ffi math math.constants byte-arrays kernel ui +ui.render combinators ui.gadgets opengl.gl accessors +namespaces opengl ; IN: cairo-demo @@ -18,14 +19,15 @@ IN: cairo-demo CAIRO_FORMAT_ARGB32 384 256 over 4 * cairo_image_surface_create_for_data ; - TUPLE: cairo-demo-gadget < gadget image-array cairo-t ; M: cairo-demo-gadget draw-gadget* ( gadget -- ) - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip - image-array>> glDrawPixels ; + origin get [ + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip + image-array>> glDrawPixels + ] with-translation ; : create-surface ( gadget -- cairo_surface_t ) make-image-array [ swap (>>image-array) ] keep @@ -34,7 +36,7 @@ M: cairo-demo-gadget draw-gadget* ( gadget -- ) : init-cairo ( gadget -- cairo_t ) create-surface cairo_create ; -M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ; +M: cairo-demo-gadget pref-dim* drop { 384 256 } ; ERROR: no-cairo-t ; From 1951d739a0f699b62e2aec683580f87845a29495 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 20:27:05 -0600 Subject: [PATCH 06/14] 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 --- basis/alien/c-types/c-types.factor | 6 +- basis/checksums/openssl/openssl.factor | 4 +- basis/cocoa/application/application.factor | 6 +- basis/cocoa/dialogs/dialogs.factor | 4 +- basis/cocoa/messages/messages.factor | 14 +- basis/cocoa/pasteboard/pasteboard.factor | 2 +- basis/cocoa/runtime/runtime.factor | 18 +- basis/cocoa/subclassing/subclassing.factor | 6 +- basis/cocoa/views/views.factor | 74 ++--- basis/compiler/compiler-docs.factor | 9 +- basis/compiler/compiler.factor | 5 +- basis/compiler/tests/codegen.factor | 4 +- basis/compiler/tests/curry.factor | 8 +- basis/compiler/tests/float.factor | 2 +- basis/compiler/tests/intrinsics.factor | 2 +- basis/compiler/tests/optimizer.factor | 9 +- basis/compiler/tests/peg-regression-2.factor | 15 + basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/tuples.factor | 2 +- .../tree/comparisons/comparisons.factor | 4 +- basis/core-foundation/strings/strings.factor | 28 +- basis/functors/functors.factor | 4 +- basis/io/backend/unix/unix.factor | 2 +- basis/none/none.factor | 2 +- basis/opengl/glu/glu.factor | 294 +++++++++--------- basis/openssl/libcrypto/libcrypto.factor | 2 +- basis/peg/parsers/parsers.factor | 4 +- basis/stack-checker/backend/backend.factor | 48 +-- .../known-words/known-words.factor | 6 + basis/threads/threads.factor | 2 +- basis/tools/deploy/config/config.factor | 8 +- basis/tools/deploy/shaker/shaker.factor | 2 +- basis/ui/cocoa/views/views.factor | 8 +- basis/ui/gadgets/buttons/buttons.factor | 2 +- basis/ui/gadgets/frames/frames.factor | 18 +- basis/ui/gadgets/sliders/sliders.factor | 2 +- basis/ui/gadgets/theme/theme.factor | 4 +- basis/ui/render/render.factor | 10 +- basis/unicode/data/data.factor | 8 +- core/bootstrap/primitives.factor | 2 +- core/compiler/units/units-docs.factor | 4 - core/compiler/units/units.factor | 3 - core/continuations/continuations.factor | 8 +- core/effects/effects.factor | 2 + core/generic/standard/standard.factor | 12 +- core/words/words-docs.factor | 4 +- core/words/words.factor | 4 +- 47 files changed, 349 insertions(+), 340 deletions(-) create mode 100644 basis/compiler/tests/peg-regression-2.factor diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a44b5cf2b6..c3fd41e689 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -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. USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting @@ -275,7 +275,7 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline -: primitive-types +CONSTANT: primitive-types { "char" "uchar" "short" "ushort" @@ -284,7 +284,7 @@ M: long-long-type box-return ( type -- ) "longlong" "ulonglong" "float" "double" "void*" "bool" - } ; + } [ diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 4bc7a7964a..58748b7c29 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -9,9 +9,9 @@ ERROR: unknown-digest 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 diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index ab2b6375a9..19d83b86d7 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -19,9 +19,9 @@ IN: cocoa.application ] curry assoc-each ] keep ; -: NSApplicationDelegateReplySuccess 0 ; -: NSApplicationDelegateReplyCancel 1 ; -: NSApplicationDelegateReplyFailure 2 ; +CONSTANT: NSApplicationDelegateReplySuccess 0 +CONSTANT: NSApplicationDelegateReplyCancel 1 +CONSTANT: NSApplicationDelegateReplyFailure 2 : with-autorelease-pool ( quot -- ) NSAutoreleasePool -> new slip -> release ; inline diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 13f6f0b7d6..84a1ad46a3 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -18,8 +18,8 @@ IN: cocoa.dialogs dup 0 -> setCanChooseDirectories: dup 0 -> setAllowsMultipleSelection: ; -: NSOKButton 1 ; -: NSCancelButton 0 ; +CONSTANT: NSOKButton 1 +CONSTANT: NSCancelButton 0 : open-panel ( -- paths ) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ce66467203..9a1bebd38f 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -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. USING: accessors alien alien.c-types alien.strings arrays assocs -continuations combinators compiler compiler.alien kernel math -namespaces make parser quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.utf8 -effects libc libc.private parser lexer init core-foundation fry -generalizations specialized-arrays.direct.alien call ; +continuations combinators compiler compiler.alien stack-checker kernel +math namespaces make parser quotations sequences strings words +cocoa.runtime io macros memoize io.encodings.utf8 effects libc +libc.private parser lexer init core-foundation fry generalizations +specialized-arrays.direct.alien call ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -14,7 +14,7 @@ IN: cocoa.messages : sender-stub ( method function -- word ) [ "( sender-stub )" f dup ] 2dip over first large-struct? [ "_stret" append ] when - make-sender define ; + make-sender dup infer define-declared ; SYMBOL: message-senders SYMBOL: super-message-senders diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index 888f5452e2..1a21b338be 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/basis/cocoa/pasteboard/pasteboard.factor @@ -5,7 +5,7 @@ cocoa.classes cocoa.application sequences cocoa core-foundation core-foundation.strings core-foundation.arrays ; IN: cocoa.pasteboard -: NSStringPboardType "NSStringPboardType" ; +CONSTANT: NSStringPboardType "NSStringPboardType" : pasteboard-string? ( pasteboard -- ? ) NSStringPboardType swap -> types CF>string-array member? ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 1a741b789f..7817d0006c 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -21,15 +21,15 @@ C-STRUCT: objc-super { "id" "receiver" } { "Class" "class" } ; -: CLS_CLASS HEX: 1 ; -: CLS_META HEX: 2 ; -: CLS_INITIALIZED HEX: 4 ; -: CLS_POSING HEX: 8 ; -: CLS_MAPPED HEX: 10 ; -: CLS_FLUSH_CACHE HEX: 20 ; -: CLS_GROW_CACHE HEX: 40 ; -: CLS_NEED_BIND HEX: 80 ; -: CLS_METHOD_ARRAY HEX: 100 ; +CONSTANT: CLS_CLASS HEX: 1 +CONSTANT: CLS_META HEX: 2 +CONSTANT: CLS_INITIALIZED HEX: 4 +CONSTANT: CLS_POSING HEX: 8 +CONSTANT: CLS_MAPPED HEX: 10 +CONSTANT: CLS_FLUSH_CACHE HEX: 20 +CONSTANT: CLS_GROW_CACHE HEX: 40 +CONSTANT: CLS_NEED_BIND HEX: 80 +CONSTANT: CLS_METHOD_ARRAY HEX: 100 FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index be53364185..0896312670 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -38,9 +38,9 @@ IN: cocoa.subclassing ] map concat ; : prepare-method ( ret types quot -- type imp ) - [ [ encode-types ] 2keep ] dip [ - "cdecl" swap 4array % \ alien-callback , - ] [ ] make define-temp ; + [ [ encode-types ] 2keep ] dip + '[ _ _ "cdecl" _ alien-callback ] + (( -- callback )) define-temp ; : prepare-methods ( methods -- methods ) [ diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index e74e912202..4bb6468fa6 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -5,43 +5,43 @@ cocoa cocoa.messages cocoa.classes cocoa.types sequences continuations accessors ; IN: cocoa.views -: NSOpenGLPFAAllRenderers 1 ; -: NSOpenGLPFADoubleBuffer 5 ; -: NSOpenGLPFAStereo 6 ; -: NSOpenGLPFAAuxBuffers 7 ; -: NSOpenGLPFAColorSize 8 ; -: NSOpenGLPFAAlphaSize 11 ; -: NSOpenGLPFADepthSize 12 ; -: NSOpenGLPFAStencilSize 13 ; -: NSOpenGLPFAAccumSize 14 ; -: NSOpenGLPFAMinimumPolicy 51 ; -: NSOpenGLPFAMaximumPolicy 52 ; -: NSOpenGLPFAOffScreen 53 ; -: NSOpenGLPFAFullScreen 54 ; -: NSOpenGLPFASampleBuffers 55 ; -: NSOpenGLPFASamples 56 ; -: NSOpenGLPFAAuxDepthStencil 57 ; -: NSOpenGLPFAColorFloat 58 ; -: NSOpenGLPFAMultisample 59 ; -: NSOpenGLPFASupersample 60 ; -: NSOpenGLPFASampleAlpha 61 ; -: NSOpenGLPFARendererID 70 ; -: NSOpenGLPFASingleRenderer 71 ; -: NSOpenGLPFANoRecovery 72 ; -: NSOpenGLPFAAccelerated 73 ; -: NSOpenGLPFAClosestPolicy 74 ; -: NSOpenGLPFARobust 75 ; -: NSOpenGLPFABackingStore 76 ; -: NSOpenGLPFAMPSafe 78 ; -: NSOpenGLPFAWindow 80 ; -: NSOpenGLPFAMultiScreen 81 ; -: NSOpenGLPFACompliant 83 ; -: NSOpenGLPFAScreenMask 84 ; -: NSOpenGLPFAPixelBuffer 90 ; -: NSOpenGLPFAAllowOfflineRenderers 96 ; -: NSOpenGLPFAVirtualScreenCount 128 ; +CONSTANT: NSOpenGLPFAAllRenderers 1 +CONSTANT: NSOpenGLPFADoubleBuffer 5 +CONSTANT: NSOpenGLPFAStereo 6 +CONSTANT: NSOpenGLPFAAuxBuffers 7 +CONSTANT: NSOpenGLPFAColorSize 8 +CONSTANT: NSOpenGLPFAAlphaSize 11 +CONSTANT: NSOpenGLPFADepthSize 12 +CONSTANT: NSOpenGLPFAStencilSize 13 +CONSTANT: NSOpenGLPFAAccumSize 14 +CONSTANT: NSOpenGLPFAMinimumPolicy 51 +CONSTANT: NSOpenGLPFAMaximumPolicy 52 +CONSTANT: NSOpenGLPFAOffScreen 53 +CONSTANT: NSOpenGLPFAFullScreen 54 +CONSTANT: NSOpenGLPFASampleBuffers 55 +CONSTANT: NSOpenGLPFASamples 56 +CONSTANT: NSOpenGLPFAAuxDepthStencil 57 +CONSTANT: NSOpenGLPFAColorFloat 58 +CONSTANT: NSOpenGLPFAMultisample 59 +CONSTANT: NSOpenGLPFASupersample 60 +CONSTANT: NSOpenGLPFASampleAlpha 61 +CONSTANT: NSOpenGLPFARendererID 70 +CONSTANT: NSOpenGLPFASingleRenderer 71 +CONSTANT: NSOpenGLPFANoRecovery 72 +CONSTANT: NSOpenGLPFAAccelerated 73 +CONSTANT: NSOpenGLPFAClosestPolicy 74 +CONSTANT: NSOpenGLPFARobust 75 +CONSTANT: NSOpenGLPFABackingStore 76 +CONSTANT: NSOpenGLPFAMPSafe 78 +CONSTANT: NSOpenGLPFAWindow 80 +CONSTANT: NSOpenGLPFAMultiScreen 81 +CONSTANT: NSOpenGLPFACompliant 83 +CONSTANT: NSOpenGLPFAScreenMask 84 +CONSTANT: NSOpenGLPFAPixelBuffer 90 +CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 +CONSTANT: NSOpenGLPFAVirtualScreenCount 128 -: kCGLRendererGenericFloatID HEX: 00020400 ; +CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 USE: opengl.gl USE: alien.syntax -: NSOpenGLCPSwapInterval 222 ; +CONSTANT: NSOpenGLCPSwapInterval 222 LIBRARY: OpenGL diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 1c6e7b796e..9169e9e0fa 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words io parser -assocs words.private sequences compiler.units ; +assocs words.private sequences compiler.units quotations ; IN: compiler HELP: enable-compiler @@ -16,6 +16,8 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" { $subsection decompile } +"Compiling a single quotation:" +{ $subsection compile-call } "Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" @@ -48,3 +50,8 @@ HELP: optimized-recompile-hook { $values { "words" "a sequence of words" } { "alist" "an association list" } } { $description "Compile a set of words." } { $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." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index f2f4e7aa9e..d707dff983 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -49,7 +49,7 @@ SYMBOL: +failed+ H{ } clone generic-dependencies set f swap compiler-error ; -: fail ( word error -- ) +: fail ( word error -- * ) [ swap compiler-error ] [ drop @@ -112,6 +112,9 @@ t compile-dependencies? set-global : decompile ( word -- ) f 2array 1array modify-code-heap ; +: compile-call ( quot -- ) + [ dup infer define-temp ] with-compilation-unit execute ; + : optimized-recompile-hook ( words -- alist ) [ compile-queue set diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 78e95ffb91..2e02e5476c 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -51,7 +51,7 @@ unit-test \ foo [ global >n get ndrop ] compile-call ] unit-test -: blech drop ; +: blech ( x -- ) drop ; [ 3 ] [ @@ -102,7 +102,7 @@ unit-test [ ] [ [ [ 200 dup [ 200 3array ] curry map drop ] times - ] [ define-temp ] with-compilation-unit drop + ] [ (( n -- )) define-temp ] with-compilation-unit drop ] unit-test ! Test how dispatch handles the end of a basic block diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 1857baf503..2d1f15b9a8 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,5 +1,5 @@ USING: tools.test quotations math kernel sequences -assocs namespaces make compiler.units ; +assocs namespaces make compiler.units compiler ; IN: compiler.tests [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test @@ -32,15 +32,15 @@ IN: compiler.tests compile-call ] unit-test -: foobar ( quot -- ) - dup slip swap [ foobar ] [ drop ] if ; inline +: foobar ( quot: ( -- ) -- ) + dup slip swap [ foobar ] [ drop ] if ; inline recursive [ ] [ [ [ 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 -: funky-assoc>map +: funky-assoc>map ( assoc quot -- seq ) [ [ call f ] curry assoc-find 3drop ] { } make ; inline diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 81ab750305..b439b5f6a4 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,5 +1,5 @@ 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 ; [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index df5f484952..6c6d580c87 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -5,7 +5,7 @@ strings.private system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii -classes ; +classes compiler ; IN: compiler.tests ! Make sure that intrinsic ops compile to correct code. diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index c5bbe4a6c3..708d17f3d3 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -3,7 +3,8 @@ stack-checker kernel kernel.private math prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private 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 GENERIC: xyz ( obj -- obj ) @@ -208,14 +209,14 @@ USE: sorting USE: binary-search USE: binary-search.private -: old-binsearch ( elt quot seq -- elt quot i ) +: old-binsearch ( elt quot: ( -- ) seq -- elt quot i ) dup length 1 <= [ from>> ] [ [ midpoint swap call ] 3keep roll dup zero? [ drop dup from>> swap midpoint@ + ] - [ dup midpoint@ cut-slice old-binsearch ] if - ] if ; inline + [ drop dup midpoint@ head-slice old-binsearch ] if + ] if ; inline recursive [ 10 ] [ 10 20 >vector diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor new file mode 100644 index 0000000000..1efadba3aa --- /dev/null +++ b/basis/compiler/tests/peg-regression-2.factor @@ -0,0 +1,15 @@ +IN: compiler.tests +USING: peg.ebnf strings tools.test ; + +GENERIC: ( times -- term' ) +M: string ; + +EBNF: parse-regexp + +Times = .* => [[ "foo" ]] + +Regexp = Times:t => [[ t ]] + +;EBNF + +[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index a6d6c5dfb9..0fde270eac 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -54,7 +54,7 @@ IN: compiler.tests ! Labels -: recursive-test ( ? -- ) [ f recursive-test ] when ; inline +: recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive [ ] [ t [ recursive-test ] compile-call ] unit-test diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index 602b438432..caa214b70c 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ IN: compiler.tests -USING: kernel tools.test compiler.units ; +USING: kernel tools.test compiler.units compiler ; TUPLE: color red green blue ; diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5242302411..5f4b1e8dab 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/basis/compiler/tree/comparisons/comparisons.factor @@ -5,9 +5,9 @@ IN: compiler.tree.comparisons ! 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 ) { diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index c3a969a325..50c17dc6fd 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -7,20 +7,20 @@ IN: core-foundation.strings TYPEDEF: void* CFStringRef TYPEDEF: int CFStringEncoding -: kCFStringEncodingMacRoman HEX: 0 ; -: kCFStringEncodingWindowsLatin1 HEX: 0500 ; -: kCFStringEncodingISOLatin1 HEX: 0201 ; -: kCFStringEncodingNextStepLatin HEX: 0B01 ; -: kCFStringEncodingASCII HEX: 0600 ; -: kCFStringEncodingUnicode HEX: 0100 ; -: kCFStringEncodingUTF8 HEX: 08000100 ; -: kCFStringEncodingNonLossyASCII HEX: 0BFF ; -: kCFStringEncodingUTF16 HEX: 0100 ; -: kCFStringEncodingUTF16BE HEX: 10000100 ; -: kCFStringEncodingUTF16LE HEX: 14000100 ; -: kCFStringEncodingUTF32 HEX: 0c000100 ; -: kCFStringEncodingUTF32BE HEX: 18000100 ; -: kCFStringEncodingUTF32LE HEX: 1c000100 ; +CONSTANT: kCFStringEncodingMacRoman HEX: 0 +CONSTANT: kCFStringEncodingWindowsLatin1 HEX: 0500 +CONSTANT: kCFStringEncodingISOLatin1 HEX: 0201 +CONSTANT: kCFStringEncodingNextStepLatin HEX: 0B01 +CONSTANT: kCFStringEncodingASCII HEX: 0600 +CONSTANT: kCFStringEncodingUnicode HEX: 0100 +CONSTANT: kCFStringEncodingUTF8 HEX: 08000100 +CONSTANT: kCFStringEncodingNonLossyASCII HEX: 0BFF +CONSTANT: kCFStringEncodingUTF16 HEX: 0100 +CONSTANT: kCFStringEncodingUTF16BE HEX: 10000100 +CONSTANT: kCFStringEncodingUTF16LE HEX: 14000100 +CONSTANT: kCFStringEncodingUTF32 HEX: 0c000100 +CONSTANT: kCFStringEncodingUTF32BE HEX: 18000100 +CONSTANT: kCFStringEncodingUTF32LE HEX: 1c000100 FUNCTION: CFStringRef CFStringCreateWithBytes ( CFAllocatorRef alloc, diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 14151692f0..0b9c9caa45 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -80,9 +80,9 @@ M: object fake-quotations> ; scan-param parsed \ 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 diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index f5e6426859..f210180517 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -77,7 +77,7 @@ M: io-timeout summary drop "I/O operation timed out" ; '[ handle>> _ wait-for-fd ] with-timeout ; ! Some general stuff -: file-mode OCT: 0666 ; +CONSTANT: file-mode OCT: 0666 ! Readers : (refill) ( port -- n ) diff --git a/basis/none/none.factor b/basis/none/none.factor index 66a0de8328..77941479aa 100644 --- a/basis/none/none.factor +++ b/basis/none/none.factor @@ -1,6 +1,6 @@ ! Just a dummy shell for the -run switch... IN: none -: none ; +: none ( -- ) ; MAIN: none diff --git a/basis/opengl/glu/glu.factor b/basis/opengl/glu/glu.factor index da19ac52fc..d603724a55 100644 --- a/basis/opengl/glu/glu.factor +++ b/basis/opengl/glu/glu.factor @@ -11,183 +11,183 @@ TYPEDEF: void* GLubyte* TYPEDEF: void* GLUfuncptr ! StringName -: GLU_VERSION 100800 ; -: GLU_EXTENSIONS 100801 ; +CONSTANT: GLU_VERSION 100800 +CONSTANT: GLU_EXTENSIONS 100801 ! ErrorCode -: GLU_INVALID_ENUM 100900 ; -: GLU_INVALID_VALUE 100901 ; -: GLU_OUT_OF_MEMORY 100902 ; -: GLU_INCOMPATIBLE_GL_VERSION 100903 ; -: GLU_INVALID_OPERATION 100904 ; +CONSTANT: GLU_INVALID_ENUM 100900 +CONSTANT: GLU_INVALID_VALUE 100901 +CONSTANT: GLU_OUT_OF_MEMORY 100902 +CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903 +CONSTANT: GLU_INVALID_OPERATION 100904 ! NurbsDisplay -: GLU_OUTLINE_POLYGON 100240 ; -: GLU_OUTLINE_PATCH 100241 ; +CONSTANT: GLU_OUTLINE_POLYGON 100240 +CONSTANT: GLU_OUTLINE_PATCH 100241 ! NurbsCallback -: GLU_NURBS_ERROR 100103 ; -: GLU_ERROR 100103 ; -: GLU_NURBS_BEGIN 100164 ; -: GLU_NURBS_BEGIN_EXT 100164 ; -: GLU_NURBS_VERTEX 100165 ; -: GLU_NURBS_VERTEX_EXT 100165 ; -: GLU_NURBS_NORMAL 100166 ; -: GLU_NURBS_NORMAL_EXT 100166 ; -: GLU_NURBS_COLOR 100167 ; -: GLU_NURBS_COLOR_EXT 100167 ; -: GLU_NURBS_TEXTURE_COORD 100168 ; -: GLU_NURBS_TEX_COORD_EXT 100168 ; -: GLU_NURBS_END 100169 ; -: GLU_NURBS_END_EXT 100169 ; -: GLU_NURBS_BEGIN_DATA 100170 ; -: GLU_NURBS_BEGIN_DATA_EXT 100170 ; -: GLU_NURBS_VERTEX_DATA 100171 ; -: GLU_NURBS_VERTEX_DATA_EXT 100171 ; -: GLU_NURBS_NORMAL_DATA 100172 ; -: GLU_NURBS_NORMAL_DATA_EXT 100172 ; -: GLU_NURBS_COLOR_DATA 100173 ; -: GLU_NURBS_COLOR_DATA_EXT 100173 ; -: GLU_NURBS_TEXTURE_COORD_DATA 100174 ; -: GLU_NURBS_TEX_COORD_DATA_EXT 100174 ; -: GLU_NURBS_END_DATA 100175 ; -: GLU_NURBS_END_DATA_EXT 100175 ; +CONSTANT: GLU_NURBS_ERROR 100103 +CONSTANT: GLU_ERROR 100103 +CONSTANT: GLU_NURBS_BEGIN 100164 +CONSTANT: GLU_NURBS_BEGIN_EXT 100164 +CONSTANT: GLU_NURBS_VERTEX 100165 +CONSTANT: GLU_NURBS_VERTEX_EXT 100165 +CONSTANT: GLU_NURBS_NORMAL 100166 +CONSTANT: GLU_NURBS_NORMAL_EXT 100166 +CONSTANT: GLU_NURBS_COLOR 100167 +CONSTANT: GLU_NURBS_COLOR_EXT 100167 +CONSTANT: GLU_NURBS_TEXTURE_COORD 100168 +CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168 +CONSTANT: GLU_NURBS_END 100169 +CONSTANT: GLU_NURBS_END_EXT 100169 +CONSTANT: GLU_NURBS_BEGIN_DATA 100170 +CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170 +CONSTANT: GLU_NURBS_VERTEX_DATA 100171 +CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171 +CONSTANT: GLU_NURBS_NORMAL_DATA 100172 +CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172 +CONSTANT: GLU_NURBS_COLOR_DATA 100173 +CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173 +CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174 +CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174 +CONSTANT: GLU_NURBS_END_DATA 100175 +CONSTANT: GLU_NURBS_END_DATA_EXT 100175 ! NurbsError -: GLU_NURBS_ERROR1 100251 ; -: GLU_NURBS_ERROR2 100252 ; -: GLU_NURBS_ERROR3 100253 ; -: GLU_NURBS_ERROR4 100254 ; -: GLU_NURBS_ERROR5 100255 ; -: GLU_NURBS_ERROR6 100256 ; -: GLU_NURBS_ERROR7 100257 ; -: GLU_NURBS_ERROR8 100258 ; -: GLU_NURBS_ERROR9 100259 ; -: GLU_NURBS_ERROR10 100260 ; -: GLU_NURBS_ERROR11 100261 ; -: GLU_NURBS_ERROR12 100262 ; -: GLU_NURBS_ERROR13 100263 ; -: GLU_NURBS_ERROR14 100264 ; -: GLU_NURBS_ERROR15 100265 ; -: GLU_NURBS_ERROR16 100266 ; -: GLU_NURBS_ERROR17 100267 ; -: GLU_NURBS_ERROR18 100268 ; -: GLU_NURBS_ERROR19 100269 ; -: GLU_NURBS_ERROR20 100270 ; -: GLU_NURBS_ERROR21 100271 ; -: GLU_NURBS_ERROR22 100272 ; -: GLU_NURBS_ERROR23 100273 ; -: GLU_NURBS_ERROR24 100274 ; -: GLU_NURBS_ERROR25 100275 ; -: GLU_NURBS_ERROR26 100276 ; -: GLU_NURBS_ERROR27 100277 ; -: GLU_NURBS_ERROR28 100278 ; -: GLU_NURBS_ERROR29 100279 ; -: GLU_NURBS_ERROR30 100280 ; -: GLU_NURBS_ERROR31 100281 ; -: GLU_NURBS_ERROR32 100282 ; -: GLU_NURBS_ERROR33 100283 ; -: GLU_NURBS_ERROR34 100284 ; -: GLU_NURBS_ERROR35 100285 ; -: GLU_NURBS_ERROR36 100286 ; -: GLU_NURBS_ERROR37 100287 ; +CONSTANT: GLU_NURBS_ERROR1 100251 +CONSTANT: GLU_NURBS_ERROR2 100252 +CONSTANT: GLU_NURBS_ERROR3 100253 +CONSTANT: GLU_NURBS_ERROR4 100254 +CONSTANT: GLU_NURBS_ERROR5 100255 +CONSTANT: GLU_NURBS_ERROR6 100256 +CONSTANT: GLU_NURBS_ERROR7 100257 +CONSTANT: GLU_NURBS_ERROR8 100258 +CONSTANT: GLU_NURBS_ERROR9 100259 +CONSTANT: GLU_NURBS_ERROR10 100260 +CONSTANT: GLU_NURBS_ERROR11 100261 +CONSTANT: GLU_NURBS_ERROR12 100262 +CONSTANT: GLU_NURBS_ERROR13 100263 +CONSTANT: GLU_NURBS_ERROR14 100264 +CONSTANT: GLU_NURBS_ERROR15 100265 +CONSTANT: GLU_NURBS_ERROR16 100266 +CONSTANT: GLU_NURBS_ERROR17 100267 +CONSTANT: GLU_NURBS_ERROR18 100268 +CONSTANT: GLU_NURBS_ERROR19 100269 +CONSTANT: GLU_NURBS_ERROR20 100270 +CONSTANT: GLU_NURBS_ERROR21 100271 +CONSTANT: GLU_NURBS_ERROR22 100272 +CONSTANT: GLU_NURBS_ERROR23 100273 +CONSTANT: GLU_NURBS_ERROR24 100274 +CONSTANT: GLU_NURBS_ERROR25 100275 +CONSTANT: GLU_NURBS_ERROR26 100276 +CONSTANT: GLU_NURBS_ERROR27 100277 +CONSTANT: GLU_NURBS_ERROR28 100278 +CONSTANT: GLU_NURBS_ERROR29 100279 +CONSTANT: GLU_NURBS_ERROR30 100280 +CONSTANT: GLU_NURBS_ERROR31 100281 +CONSTANT: GLU_NURBS_ERROR32 100282 +CONSTANT: GLU_NURBS_ERROR33 100283 +CONSTANT: GLU_NURBS_ERROR34 100284 +CONSTANT: GLU_NURBS_ERROR35 100285 +CONSTANT: GLU_NURBS_ERROR36 100286 +CONSTANT: GLU_NURBS_ERROR37 100287 ! NurbsProperty -: GLU_AUTO_LOAD_MATRIX 100200 ; -: GLU_CULLING 100201 ; -: GLU_SAMPLING_TOLERANCE 100203 ; -: GLU_DISPLAY_MODE 100204 ; -: GLU_PARAMETRIC_TOLERANCE 100202 ; -: GLU_SAMPLING_METHOD 100205 ; -: GLU_U_STEP 100206 ; -: GLU_V_STEP 100207 ; -: GLU_NURBS_MODE 100160 ; -: GLU_NURBS_MODE_EXT 100160 ; -: GLU_NURBS_TESSELLATOR 100161 ; -: GLU_NURBS_TESSELLATOR_EXT 100161 ; -: GLU_NURBS_RENDERER 100162 ; -: GLU_NURBS_RENDERER_EXT 100162 ; +CONSTANT: GLU_AUTO_LOAD_MATRIX 100200 +CONSTANT: GLU_CULLING 100201 +CONSTANT: GLU_SAMPLING_TOLERANCE 100203 +CONSTANT: GLU_DISPLAY_MODE 100204 +CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202 +CONSTANT: GLU_SAMPLING_METHOD 100205 +CONSTANT: GLU_U_STEP 100206 +CONSTANT: GLU_V_STEP 100207 +CONSTANT: GLU_NURBS_MODE 100160 +CONSTANT: GLU_NURBS_MODE_EXT 100160 +CONSTANT: GLU_NURBS_TESSELLATOR 100161 +CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161 +CONSTANT: GLU_NURBS_RENDERER 100162 +CONSTANT: GLU_NURBS_RENDERER_EXT 100162 ! NurbsSampling -: GLU_OBJECT_PARAMETRIC_ERROR 100208 ; -: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 ; -: GLU_OBJECT_PATH_LENGTH 100209 ; -: GLU_OBJECT_PATH_LENGTH_EXT 100209 ; -: GLU_PATH_LENGTH 100215 ; -: GLU_PARAMETRIC_ERROR 100216 ; -: GLU_DOMAIN_DISTANCE 100217 ; +CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208 +CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 +CONSTANT: GLU_OBJECT_PATH_LENGTH 100209 +CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209 +CONSTANT: GLU_PATH_LENGTH 100215 +CONSTANT: GLU_PARAMETRIC_ERROR 100216 +CONSTANT: GLU_DOMAIN_DISTANCE 100217 ! NurbsTrim -: GLU_MAP1_TRIM_2 100210 ; -: GLU_MAP1_TRIM_3 100211 ; +CONSTANT: GLU_MAP1_TRIM_2 100210 +CONSTANT: GLU_MAP1_TRIM_3 100211 ! QuadricDrawStyle -: GLU_POINT 100010 ; -: GLU_LINE 100011 ; -: GLU_FILL 100012 ; -: GLU_SILHOUETTE 100013 ; +CONSTANT: GLU_POINT 100010 +CONSTANT: GLU_LINE 100011 +CONSTANT: GLU_FILL 100012 +CONSTANT: GLU_SILHOUETTE 100013 ! QuadricNormal -: GLU_SMOOTH 100000 ; -: GLU_FLAT 100001 ; -: GLU_NONE 100002 ; +CONSTANT: GLU_SMOOTH 100000 +CONSTANT: GLU_FLAT 100001 +CONSTANT: GLU_NONE 100002 ! QuadricOrientation -: GLU_OUTSIDE 100020 ; -: GLU_INSIDE 100021 ; +CONSTANT: GLU_OUTSIDE 100020 +CONSTANT: GLU_INSIDE 100021 ! TessCallback -: GLU_TESS_BEGIN 100100 ; -: GLU_BEGIN 100100 ; -: GLU_TESS_VERTEX 100101 ; -: GLU_VERTEX 100101 ; -: GLU_TESS_END 100102 ; -: GLU_END 100102 ; -: GLU_TESS_ERROR 100103 ; -: GLU_TESS_EDGE_FLAG 100104 ; -: GLU_EDGE_FLAG 100104 ; -: GLU_TESS_COMBINE 100105 ; -: GLU_TESS_BEGIN_DATA 100106 ; -: GLU_TESS_VERTEX_DATA 100107 ; -: GLU_TESS_END_DATA 100108 ; -: GLU_TESS_ERROR_DATA 100109 ; -: GLU_TESS_EDGE_FLAG_DATA 100110 ; -: GLU_TESS_COMBINE_DATA 100111 ; +CONSTANT: GLU_TESS_BEGIN 100100 +CONSTANT: GLU_BEGIN 100100 +CONSTANT: GLU_TESS_VERTEX 100101 +CONSTANT: GLU_VERTEX 100101 +CONSTANT: GLU_TESS_END 100102 +CONSTANT: GLU_END 100102 +CONSTANT: GLU_TESS_ERROR 100103 +CONSTANT: GLU_TESS_EDGE_FLAG 100104 +CONSTANT: GLU_EDGE_FLAG 100104 +CONSTANT: GLU_TESS_COMBINE 100105 +CONSTANT: GLU_TESS_BEGIN_DATA 100106 +CONSTANT: GLU_TESS_VERTEX_DATA 100107 +CONSTANT: GLU_TESS_END_DATA 100108 +CONSTANT: GLU_TESS_ERROR_DATA 100109 +CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110 +CONSTANT: GLU_TESS_COMBINE_DATA 100111 ! TessContour -: GLU_CW 100120 ; -: GLU_CCW 100121 ; -: GLU_INTERIOR 100122 ; -: GLU_EXTERIOR 100123 ; -: GLU_UNKNOWN 100124 ; +CONSTANT: GLU_CW 100120 +CONSTANT: GLU_CCW 100121 +CONSTANT: GLU_INTERIOR 100122 +CONSTANT: GLU_EXTERIOR 100123 +CONSTANT: GLU_UNKNOWN 100124 ! TessProperty -: GLU_TESS_WINDING_RULE 100140 ; -: GLU_TESS_BOUNDARY_ONLY 100141 ; -: GLU_TESS_TOLERANCE 100142 ; +CONSTANT: GLU_TESS_WINDING_RULE 100140 +CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141 +CONSTANT: GLU_TESS_TOLERANCE 100142 ! TessError -: GLU_TESS_ERROR1 100151 ; -: GLU_TESS_ERROR2 100152 ; -: GLU_TESS_ERROR3 100153 ; -: GLU_TESS_ERROR4 100154 ; -: GLU_TESS_ERROR5 100155 ; -: GLU_TESS_ERROR6 100156 ; -: GLU_TESS_ERROR7 100157 ; -: GLU_TESS_ERROR8 100158 ; -: GLU_TESS_MISSING_BEGIN_POLYGON 100151 ; -: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 ; -: GLU_TESS_MISSING_END_POLYGON 100153 ; -: GLU_TESS_MISSING_END_CONTOUR 100154 ; -: GLU_TESS_COORD_TOO_LARGE 100155 ; -: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ; +CONSTANT: GLU_TESS_ERROR1 100151 +CONSTANT: GLU_TESS_ERROR2 100152 +CONSTANT: GLU_TESS_ERROR3 100153 +CONSTANT: GLU_TESS_ERROR4 100154 +CONSTANT: GLU_TESS_ERROR5 100155 +CONSTANT: GLU_TESS_ERROR6 100156 +CONSTANT: GLU_TESS_ERROR7 100157 +CONSTANT: GLU_TESS_ERROR8 100158 +CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151 +CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 +CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153 +CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154 +CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155 +CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ! TessWinding -: GLU_TESS_WINDING_ODD 100130 ; -: GLU_TESS_WINDING_NONZERO 100131 ; -: GLU_TESS_WINDING_POSITIVE 100132 ; -: GLU_TESS_WINDING_NEGATIVE 100133 ; -: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 ; +CONSTANT: GLU_TESS_WINDING_ODD 100130 +CONSTANT: GLU_TESS_WINDING_NONZERO 100131 +CONSTANT: GLU_TESS_WINDING_POSITIVE 100132 +CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133 +CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 LIBRARY: glu diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index 3204b83bbb..9cbed1f752 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -99,7 +99,7 @@ FUNCTION: void* BIO_f_buffer ( ) ; ! evp.h ! =============================================== -: EVP_MAX_MD_SIZE 64 ; +CONSTANT: EVP_MAX_MD_SIZE 64 C-STRUCT: EVP_MD_CTX { "EVP_MD*" "digest" } diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index a9fb366812..aadbbaff16 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -7,12 +7,12 @@ IN: peg.parsers TUPLE: just-parser p1 ; -: just-pattern +CONSTANT: just-pattern [ execute dup [ dup remaining>> empty? [ drop f ] unless ] when - ] ; + ] M: just-parser (compile) ( parser -- quot ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index b08bdd8436..5f7eb5ceae 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -124,18 +124,13 @@ M: object apply-object push-literal ; : undo-infer ( -- ) recorded get [ f "inferred-effect" set-word-prop ] each ; -: consume/produce ( effect quot -- ) - #! quot is ( inputs outputs -- ) - [ - [ - [ in>> length consume-d ] - [ out>> length produce-d ] - bi - ] dip call - ] [ - drop - terminated?>> [ terminate ] when - ] 2bi ; inline +: (consume/produce) ( effect -- inputs outputs ) + [ in>> length consume-d ] [ out>> length produce-d ] bi ; + +: consume/produce ( effect quot: ( inputs outputs -- ) -- ) + '[ (consume/produce) @ ] + [ terminated?>> [ terminate ] when ] + bi ; inline : infer-word-def ( word -- ) [ specialized-def ] [ add-recursive-state ] bi infer-quot ; @@ -143,23 +138,12 @@ M: object apply-object push-literal ; : end-infer ( -- ) meta-d clone #return, ; -: effect-required? ( word -- ? ) - { - { [ 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 ; +: required-stack-effect ( word -- effect ) + dup stack-effect [ ] [ missing-effect inference-error ] ?if ; : check-effect ( word effect -- ) - over stack-effect { - { [ dup not ] [ 2drop ?missing-effect ] } - { [ 2dup effect<= ] [ 3drop ] } - [ effect-error ] - } cond ; + over required-stack-effect 2dup effect<= + [ 3drop ] [ effect-error ] if ; : finish-word ( word -- ) current-effect @@ -183,22 +167,20 @@ M: object apply-object push-literal ; dependencies off generic-dependencies off [ infer-word-def end-infer ] - [ finish-word current-effect ] - bi + [ finish-word ] + [ stack-effect ] + tri ] with-scope ] maybe-cannot-infer ; : apply-word/effect ( word effect -- ) swap '[ _ #call, ] consume/produce ; -: required-stack-effect ( word -- effect ) - dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ; - : call-recursive-word ( word -- ) dup required-stack-effect apply-word/effect ; : cached-infer ( word -- ) - dup "inferred-effect" word-prop apply-word/effect ; + dup stack-effect apply-word/effect ; : with-infer ( quot -- effect visitor ) [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 56aebb20e7..4ac9d802ed 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -319,12 +319,18 @@ M: object infer-call* \ fixnum/i { fixnum fixnum } { integer } define-primitive \ 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 make-foldable \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ 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 make-foldable diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 305ef0cca3..8556167009 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -118,7 +118,7 @@ DEFER: stop [ ] while drop ; -: start ( namestack thread -- ) +: start ( namestack thread -- * ) [ set-self set-namestack diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 1d9761e885..63c8393b51 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -14,12 +14,12 @@ SYMBOL: deploy-threads? SYMBOL: deploy-io -: deploy-io-options +CONSTANT: deploy-io-options { { 1 "Level 1 - No input/output" } { 2 "Level 2 - Basic ANSI C streams" } { 3 "Level 3 - Non-blocking streams and networking" } - } ; + } : strip-io? ( -- ? ) deploy-io get 1 = ; @@ -27,7 +27,7 @@ SYMBOL: deploy-io SYMBOL: deploy-reflection -: deploy-reflection-options +CONSTANT: deploy-reflection-options { { 1 "Level 1 - No reflection" } { 2 "Level 2 - Retain word names" } @@ -35,7 +35,7 @@ SYMBOL: deploy-reflection { 4 "Level 4 - Debugger" } { 5 "Level 5 - Parser" } { 6 "Level 6 - Full environment" } - } ; + } : strip-word-names? ( -- ? ) deploy-reflection get 2 < ; : strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5095f9e93e..e61021e633 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -190,7 +190,7 @@ IN: tools.deploy.shaker "Stripping default methods" show [ [ generic? ] instances - [ "No method" throw ] define-temp + [ "No method" throw ] (( -- * )) define-temp dup t "default" set-word-prop '[ [ _ "default-method" set-word-prop ] [ make-generic ] bi diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 3201779cc5..9e32f2f4de 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -14,15 +14,15 @@ IN: ui.cocoa.views #! Cocoa -> Factor UI button mapping -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ; -: modifiers +CONSTANT: modifiers { { S+ HEX: 20000 } { C+ HEX: 40000 } { A+ HEX: 100000 } { M+ HEX: 80000 } - } ; + } -: key-codes +CONSTANT: key-codes H{ { 71 "CLEAR" } { 36 "RET" } @@ -47,7 +47,7 @@ IN: ui.cocoa.views { 126 "UP" } { 116 "PAGE_UP" } { 121 "PAGE_DOWN" } - } ; + } : key-code ( event -- string ? ) dup -> keyCode key-codes at diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index dabc12d3ae..3deb280c83 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -173,7 +173,7 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ; diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index ae4c7d929a..a4d6b46129 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -13,16 +13,16 @@ M: glue pref-dim* drop { 0 0 } ; : ( -- grid ) 9 [ ] replicate 3 group ; -: @center 1 1 ; inline -: @left 0 1 ; inline -: @right 2 1 ; inline -: @top 1 0 ; inline -: @bottom 1 2 ; inline +: @center ( -- i j ) 1 1 ; inline +: @left ( -- i j ) 0 1 ; inline +: @right ( -- i j ) 2 1 ; inline +: @top ( -- i j ) 1 0 ; inline +: @bottom ( -- i j ) 1 2 ; inline -: @top-left 0 0 ; inline -: @top-right 2 0 ; inline -: @bottom-left 0 2 ; inline -: @bottom-right 2 2 ; inline +: @top-left ( -- i j ) 0 0 ; inline +: @top-right ( -- i j ) 2 0 ; inline +: @bottom-left ( -- i j ) 0 2 ; inline +: @bottom-right ( -- i j ) 2 2 ; inline TUPLE: frame < grid ; diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 1c2055156e..f22bd08ba2 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -18,7 +18,7 @@ TUPLE: slider < frame elevator thumb saved line ; : elevator-length ( slider -- n ) [ elevator>> dim>> ] [ orientation>> ] bi v. ; -: min-thumb-dim 15 ; +CONSTANT: min-thumb-dim 15 : slider-value ( gadget -- n ) model>> range-value >fixnum ; : slider-page ( gadget -- n ) model>> range-page-value ; diff --git a/basis/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor index 6ca3868d87..7dabd994c2 100644 --- a/basis/ui/gadgets/theme/theme.factor +++ b/basis/ui/gadgets/theme/theme.factor @@ -56,6 +56,6 @@ IN: ui.gadgets.theme T{ gray f 0.5 1.0 } } ; -: 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 } diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 5cbac9798a..a913c78f7d 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -191,11 +191,11 @@ M: polygon draw-interior [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ] tri ; -: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ; -: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ; -: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ; -: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ; -: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ; +CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } } +CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } } +CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } } +CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } } +CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } : ( color points -- gadget ) dup max-dim diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index de8d28ad2e..bff4ddeaab 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -97,8 +97,8 @@ VALUE: properties [ nip zero? not ] assoc-filter >hashtable ; -: categories ( -- names ) - ! For non-existent characters, use Cn +! For non-existent characters, use Cn +CONSTANT: categories { "Cn" "Lu" "Ll" "Lt" "Lm" "Lo" "Mn" "Mc" "Me" @@ -106,9 +106,9 @@ VALUE: properties "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" "Sm" "Sc" "Sk" "So" "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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ceeab571b8..9e064cf99c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -538,4 +538,4 @@ tuple [ [ first2 ] dip make-primitive ] each-index ! Bump build number -"build" "kernel" create build 1+ 1quotation define +"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 09baf91018..46d3dbc33f 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -67,7 +67,3 @@ HELP: modify-code-heap ( alist -- ) HELP: compile { $values { "words" "a sequence of words" } } { $description "Compiles a set of words." } ; - -HELP: compile-call -{ $values { "quot" "a quotation" } } -{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index ac3e99e24c..0577f8b83c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -172,9 +172,6 @@ SYMBOL: remake-generics-hook ] [ ] cleanup ] with-scope ; inline -: compile-call ( quot -- ) - [ define-temp ] with-compilation-unit execute ; - : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index c7056856b6..37418b85f5 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -92,10 +92,10 @@ C: continuation PRIVATE> -: continue-with ( obj continuation -- ) +: continue-with ( obj continuation -- * ) [ (continue-with) ] 2 (throw) ; -: continue ( continuation -- ) +: continue ( continuation -- * ) f swap continue-with ; SYMBOL: return-continuation @@ -103,7 +103,7 @@ SYMBOL: return-continuation : with-return ( quot -- ) [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline -: return ( -- ) +: return ( -- * ) return-continuation get continue ; : with-datastack ( stack quot -- newstack ) @@ -173,7 +173,7 @@ TUPLE: restart name obj continuation ; C: restart -: restart ( restart -- ) +: restart ( restart -- * ) [ obj>> ] [ continuation>> ] bi continue-with ; M: object compute-restarts drop { } ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 8a06653eb8..0e40d926d8 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -48,6 +48,8 @@ M: word stack-effect { "declared-effect" "inferred-effect" } swap props>> [ at ] curry map [ ] find nip ; +M: deferred stack-effect call-next-method (( -- * )) or ; + M: effect clone [ in>> clone ] [ out>> clone ] bi ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 9ace1a01f4..f9fe3a6e9e 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -50,16 +50,16 @@ ERROR: no-method object generic ; convert-hi-tag-methods ; +: mangle-method ( method -- quot ) + 1quotation generic get extra-values \ drop + prepend [ ] like ; + : find-default ( methods -- quot ) #! Side-effects methods. object bootstrap-word swap delete-at* [ - drop generic get "default-method" word-prop 1quotation + drop generic get "default-method" word-prop mangle-method ] unless ; -: mangle-method ( method generic -- quot ) - [ 1quotation ] [ extra-values \ drop ] bi* - prepend [ ] like ; - : ( word -- engine ) object bootstrap-word assumed set { [ generic set ] @@ -67,7 +67,7 @@ ERROR: no-method object generic ; [ V{ } clone "engines" set-word-prop ] [ "methods" word-prop - [ generic get mangle-method ] assoc-map + [ mangle-method ] assoc-map [ find-default default set ] [ ] bi diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 4dfa2d49bc..f5990c295e 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -288,12 +288,12 @@ HELP: define-declared { $side-effects "word" } ; 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." } { $notes "The following phrases are equivalent:" { $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 } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index 4a3c1b2d52..43a391e46a 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -212,8 +212,8 @@ M: word subwords drop f ; : gensym ( -- word ) "( gensym )" f ; -: define-temp ( quot -- word ) - [ gensym dup ] dip define ; +: define-temp ( quot effect -- word ) + [ gensym dup ] 2dip define-declared ; : reveal ( word -- ) dup [ name>> ] [ vocabulary>> ] bi dup vocab-words From f1d20719b2b7a75662cea4037c61b2b589da6e94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 20:51:14 -0600 Subject: [PATCH 07/14] inferred-effect word prop is just a boolean now, not an effect object --- basis/stack-checker/backend/backend.factor | 9 ++++----- core/effects/effects.factor | 4 +--- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 5f7eb5ceae..3c298bdfed 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -146,11 +146,10 @@ M: object apply-object push-literal ; [ 3drop ] [ effect-error ] if ; : finish-word ( word -- ) - current-effect - [ check-effect ] - [ drop recorded get push ] - [ "inferred-effect" set-word-prop ] - 2tri ; + [ current-effect check-effect ] + [ recorded get push ] + [ t "inferred-effect" set-word-prop ] + tri ; : cannot-infer-effect ( word -- * ) "cannot-infer" word-prop throw ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 0e40d926d8..a9f9634d46 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -44,9 +44,7 @@ M: effect effect>string ( effect -- string ) GENERIC: stack-effect ( word -- effect/f ) -M: word stack-effect - { "declared-effect" "inferred-effect" } - swap props>> [ at ] curry map [ ] find nip ; +M: word stack-effect "declared-effect" word-prop ; M: deferred stack-effect call-next-method (( -- * )) or ; From eaad0c766018f8c3eec6cb242a3169e911f975bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 21:40:17 -0600 Subject: [PATCH 08/14] Updating code to use CONSTANT: instead of : foo 123 ; inline --- .../bootstrap/image/download/download.factor | 2 +- basis/cairo/ffi/ffi.factor | 6 +- basis/farkup/farkup.factor | 2 +- basis/furnace/actions/actions.factor | 2 +- basis/furnace/alloy/alloy.factor | 2 +- basis/furnace/asides/asides.factor | 2 +- basis/furnace/auth/login/login.factor | 2 +- basis/furnace/auth/providers/null/null.factor | 4 +- .../conversations/conversations.factor | 2 +- basis/furnace/sessions/sessions.factor | 2 +- basis/furnace/utilities/utilities.factor | 4 +- .../html/templates/chloe/syntax/syntax.factor | 2 +- basis/io/encodings/8-bit/8-bit.factor | 11 +- basis/logging/server/server.factor | 2 +- basis/math/quaternions/quaternions.factor | 10 +- basis/windows/kernel32/kernel32.factor | 4 +- basis/x11/constants/constants.factor | 350 +++++++++--------- basis/x11/glx/glx.factor | 34 +- basis/x11/xim/xim.factor | 2 +- basis/xml/entities/entities.factor | 12 +- basis/xml/errors/errors.factor | 4 +- extra/24-game/24-game.factor | 2 +- extra/benchmark/backtrack/backtrack.factor | 4 +- extra/benchmark/fasta/fasta.factor | 10 +- extra/benchmark/raytracer/raytracer.factor | 7 +- extra/benchmark/sockets/sockets.factor | 2 +- extra/galois-talk/galois-talk.factor | 4 +- extra/game-input/iokit/iokit.factor | 4 +- .../google-tech-talk/google-tech-talk.factor | 4 +- extra/irc/client/client.factor | 2 +- extra/irc/ui/ui.factor | 6 +- extra/joystick-demo/joystick-demo.factor | 8 +- extra/key-caps/key-caps.factor | 6 +- extra/lint/lint.factor | 2 +- extra/lisppaste/lisppaste.factor | 2 +- extra/mason/common/common.factor | 28 +- extra/math/analysis/analysis.factor | 4 +- extra/maze/maze.factor | 2 +- .../minneapolis-talk/minneapolis-talk.factor | 4 +- extra/minneapolis-talk/minneapolis-talk.txt | 116 ------ extra/nehe/2/2.factor | 4 +- extra/nehe/3/3.factor | 4 +- extra/nehe/4/4.factor | 4 +- extra/nehe/5/5.factor | 4 +- extra/otug-talk/otug-talk.factor | 4 +- extra/slides/slides.factor | 4 +- extra/vpri-talk/vpri-talk.factor | 4 +- extra/yahoo/yahoo.factor | 6 +- unfinished/benchmark/richards/richards.factor | 272 -------------- unfinished/sql/sql-tests.factor | 42 --- unfinished/sql/sql.factor | 172 --------- 51 files changed, 295 insertions(+), 903 deletions(-) delete mode 100755 extra/minneapolis-talk/minneapolis-talk.txt delete mode 100644 unfinished/benchmark/richards/richards.factor delete mode 100644 unfinished/sql/sql-tests.factor delete mode 100755 unfinished/sql/sql.factor diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index f9b7b56779..5bfc5f7ccc 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -4,7 +4,7 @@ USING: http.client checksums checksums.md5 splitting assocs kernel io.files bootstrap.image sequences io urls ; IN: bootstrap.image.download -: url URL" http://factorcode.org/images/latest/" ; +CONSTANT: url URL" http://factorcode.org/images/latest/" : download-checksums ( -- alist ) url "checksums.txt" >url derive-url http-get nip diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index d29a3fb097..c2daa05374 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -72,9 +72,9 @@ C-ENUM: CAIRO_STATUS_INVALID_STRIDE ; TYPEDEF: int cairo_content_t -: CAIRO_CONTENT_COLOR HEX: 1000 ; -: CAIRO_CONTENT_ALPHA HEX: 2000 ; -: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; +CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000 +CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000 +CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 TYPEDEF: void* cairo_write_func_t : cairo-write-func ( quot -- callback ) diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index eea30a3040..50ee938659 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -157,7 +157,7 @@ stand-alone = (line | code | heading | list | table | paragraph | nl)* ;EBNF -: invalid-url "javascript:alert('Invalid URL in farkup');" ; +CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');" : check-url ( href -- href' ) { diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 97cb73c9cb..166d2a88a2 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -63,7 +63,7 @@ TUPLE: action rest init authorize display validate submit ; : param ( name -- value ) params get at ; -: revalidate-url-key "__u" ; +CONSTANT: revalidate-url-key "__u" : revalidate-url ( -- url/f ) revalidate-url-key param diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 0fe80427b9..dc280c1e44 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -10,7 +10,7 @@ furnace.auth.providers furnace.auth.login.permits ; IN: furnace.alloy -: state-classes { session aside conversation permit } ; inline +CONSTANT: state-classes { session aside conversation permit } : init-furnace-tables ( -- ) state-classes ensure-tables diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 7489d19f94..ecf6d0a628 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -23,7 +23,7 @@ aside "ASIDES" { { "post-data" "POST_DATA" FACTOR-BLOB } } define-persistent -: aside-id-key "__a" ; +CONSTANT: aside-id-key "__a" TUPLE: asides < server-state-manager ; diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 0ceafa7f86..915ae1c224 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -64,7 +64,7 @@ SYMBOL: capabilities PRIVATE> -: flashed-variables { description capabilities } ; +CONSTANT: flashed-variables { description capabilities } : login-failed ( -- * ) "invalid username or password" validation-error diff --git a/basis/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor index 39ea812ae7..0fab3c5b09 100644 --- a/basis/furnace/auth/providers/null/null.factor +++ b/basis/furnace/auth/providers/null/null.factor @@ -3,9 +3,7 @@ USING: furnace.auth.providers kernel ; IN: furnace.auth.providers.null -TUPLE: no-users ; - -: no-users T{ no-users } ; +SINGLETON: no-users M: no-users get-user 2drop f ; diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 266958c8a4..bbb84e2f05 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -20,7 +20,7 @@ conversation "CONVERSATIONS" { { "session" "SESSION" BIG-INTEGER +not-null+ } } define-persistent -: conversation-id-key "__c" ; +CONSTANT: conversation-id-key "__c" TUPLE: conversations < server-state-manager ; diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 52e705c153..3eb7a11215 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -73,7 +73,7 @@ TUPLE: sessions < server-state-manager domain verify? ; [ session set ] [ save-session-after ] bi sessions get responder>> call-responder ; -: session-id-key "__s" ; +CONSTANT: session-id-key "__s" : verify-session ( session -- session ) sessions get verify?>> [ diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 4fc68f7735..c0cb7dbced 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -89,7 +89,7 @@ M: object modify-form drop f ; [XML name=<->/> XML] ] [ drop ] if ; -: nested-forms-key "__n" ; +CONSTANT: nested-forms-key "__n" : request-params ( request -- assoc ) dup method>> { @@ -131,7 +131,7 @@ M: object modify-form drop f ; SYMBOL: exit-continuation -: exit-with ( value -- ) +: exit-with ( value -- * ) exit-continuation get continue-with ; : with-exit-continuation ( quot -- value ) diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index faf8bed66b..9e7079023d 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -18,7 +18,7 @@ tags [ H{ } clone ] initialize : CHLOE: scan parse-definition define-chloe-tag ; parsing -: chloe-ns "http://factorcode.org/chloe/1.0" ; inline +CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0" : chloe-name? ( name -- ? ) url>> chloe-ns = ; diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor index bad2d9fd82..9ef2b07322 100644 --- a/basis/io/encodings/8-bit/8-bit.factor +++ b/basis/io/encodings/8-bit/8-bit.factor @@ -4,12 +4,12 @@ USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii generic parser classes.tuple words words.symbol io io.files splitting namespaces math compiler.units accessors classes.singleton classes.mixin -io.encodings.iana ; +io.encodings.iana fry ; IN: io.encodings.8-bit ch ( assoc -- array ) 256 replacement-char - [ [ swapd set-nth ] curry assoc-each ] keep ; + [ '[ swap _ set-nth ] assoc-each ] keep ; : ch>byte ( assoc -- newassoc ) [ swap ] assoc-map >hashtable ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 618dba544c..7dced852fd 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -63,7 +63,7 @@ SYMBOL: log-files dup values [ try-dispose ] each clear-assoc ; -: keep-logs 10 ; +CONSTANT: keep-logs 10 : ?delete-file ( path -- ) dup exists? [ delete-file ] [ drop ] if ; diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor index bc6da9f564..f2c2c6d226 100755 --- a/basis/math/quaternions/quaternions.factor +++ b/basis/math/quaternions/quaternions.factor @@ -45,13 +45,13 @@ PRIVATE> first2 [ imaginary-part ] dip >rect 3array ; ! Zero -: q0 { 0 0 } ; +CONSTANT: q0 { 0 0 } ! Units -: q1 { 1 0 } ; -: qi { C{ 0 1 } 0 } ; -: qj { 0 1 } ; -: qk { 0 C{ 0 1 } } ; +CONSTANT: q1 { 1 0 } +CONSTANT: qi { C{ 0 1 } 0 } +CONSTANT: qj { 0 1 } +CONSTANT: qk { 0 C{ 0 1 } } ! Euler angles diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 8a271f7210..36acc5e346 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -993,8 +993,8 @@ FUNCTION: BOOL DuplicateHandle ( BOOL bInheritHandle, DWORD dwOptions ) ; -: DUPLICATE_CLOSE_SOURCE 1 ; -: DUPLICATE_SAME_ACCESS 2 ; +CONSTANT: DUPLICATE_CLOSE_SOURCE 1 +CONSTANT: DUPLICATE_SAME_ACCESS 2 ! FUNCTION: EncodePointer ! FUNCTION: EncodeSystemPointer diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor index fcce09380f..1fe825d6af 100644 --- a/basis/x11/constants/constants.factor +++ b/basis/x11/constants/constants.factor @@ -12,17 +12,17 @@ TYPEDEF: uchar KeyCode ! Reserved Resource and Constant Definitions -: ParentRelative 1 ; -: CopyFromParent 0 ; -: PointerWindow 0 ; -: InputFocus 1 ; -: PointerRoot 1 ; -: AnyPropertyType 0 ; -: AnyKey 0 ; -: AnyButton 0 ; -: AllTemporary 0 ; -: CurrentTime 0 ; -: NoSymbol 0 ; +CONSTANT: ParentRelative 1 +CONSTANT: CopyFromParent 0 +CONSTANT: PointerWindow 0 +CONSTANT: InputFocus 1 +CONSTANT: PointerRoot 1 +CONSTANT: AnyPropertyType 0 +CONSTANT: AnyKey 0 +CONSTANT: AnyButton 0 +CONSTANT: AllTemporary 0 +CONSTANT: CurrentTime 0 +CONSTANT: NoSymbol 0 ! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, ! state in various key-, mouse-, and button-related events. @@ -31,14 +31,14 @@ TYPEDEF: uchar KeyCode ! modifier names. Used to build a SetModifierMapping request or ! to read a GetModifierMapping request. These correspond to the ! masks defined above. -: ShiftMapIndex 0 ; -: LockMapIndex 1 ; -: ControlMapIndex 2 ; -: Mod1MapIndex 3 ; -: Mod2MapIndex 4 ; -: Mod3MapIndex 5 ; -: Mod4MapIndex 6 ; -: Mod5MapIndex 7 ; +CONSTANT: ShiftMapIndex 0 +CONSTANT: LockMapIndex 1 +CONSTANT: ControlMapIndex 2 +CONSTANT: Mod1MapIndex 3 +CONSTANT: Mod2MapIndex 4 +CONSTANT: Mod3MapIndex 5 +CONSTANT: Mod4MapIndex 6 +CONSTANT: Mod5MapIndex 7 ! button masks. Used in same manner as Key masks above. Not to be confused @@ -53,100 +53,100 @@ TYPEDEF: uchar KeyCode ! Notify modes -: NotifyNormal 0 ; -: NotifyGrab 1 ; -: NotifyUngrab 2 ; -: NotifyWhileGrabbed 3 ; +CONSTANT: NotifyNormal 0 +CONSTANT: NotifyGrab 1 +CONSTANT: NotifyUngrab 2 +CONSTANT: NotifyWhileGrabbed 3 -: NotifyHint 1 ; ! for MotionNotify events +CONSTANT: NotifyHint 1 ! for MotionNotify events ! Notify detail -: NotifyAncestor 0 ; -: NotifyVirtual 1 ; -: NotifyInferior 2 ; -: NotifyNonlinear 3 ; -: NotifyNonlinearVirtual 4 ; -: NotifyPointer 5 ; -: NotifyPointerRoot 6 ; -: NotifyDetailNone 7 ; +CONSTANT: NotifyAncestor 0 +CONSTANT: NotifyVirtual 1 +CONSTANT: NotifyInferior 2 +CONSTANT: NotifyNonlinear 3 +CONSTANT: NotifyNonlinearVirtual 4 +CONSTANT: NotifyPointer 5 +CONSTANT: NotifyPointerRoot 6 +CONSTANT: NotifyDetailNone 7 ! Visibility notify -: VisibilityUnobscured 0 ; -: VisibilityPartiallyObscured 1 ; -: VisibilityFullyObscured 2 ; +CONSTANT: VisibilityUnobscured 0 +CONSTANT: VisibilityPartiallyObscured 1 +CONSTANT: VisibilityFullyObscured 2 ! Circulation request -: PlaceOnTop 0 ; -: PlaceOnBottom 1 ; +CONSTANT: PlaceOnTop 0 +CONSTANT: PlaceOnBottom 1 ! protocol families -: FamilyInternet 0 ; ! IPv4 -: FamilyDECnet 1 ; -: FamilyChaos 2 ; -: FamilyInternet6 6 ; ! IPv6 +CONSTANT: FamilyInternet 0 ! IPv4 +CONSTANT: FamilyDECnet 1 +CONSTANT: FamilyChaos 2 +CONSTANT: FamilyInternet6 6 ! IPv6 ! authentication families not tied to a specific protocol -: FamilyServerInterpreted 5 ; +CONSTANT: FamilyServerInterpreted 5 ! Property notification -: PropertyNewValue 0 ; -: PropertyDelete 1 ; +CONSTANT: PropertyNewValue 0 +CONSTANT: PropertyDelete 1 ! Color Map notification -: ColormapUninstalled 0 ; -: ColormapInstalled 1 ; +CONSTANT: ColormapUninstalled 0 +CONSTANT: ColormapInstalled 1 ! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes -: GrabModeSync 0 ; -: GrabModeAsync 1 ; +CONSTANT: GrabModeSync 0 +CONSTANT: GrabModeAsync 1 ! GrabPointer, GrabKeyboard reply status -: GrabSuccess 0 ; -: AlreadyGrabbed 1 ; -: GrabInvalidTime 2 ; -: GrabNotViewable 3 ; -: GrabFrozen 4 ; +CONSTANT: GrabSuccess 0 +CONSTANT: AlreadyGrabbed 1 +CONSTANT: GrabInvalidTime 2 +CONSTANT: GrabNotViewable 3 +CONSTANT: GrabFrozen 4 ! AllowEvents modes -: AsyncPointer 0 ; -: SyncPointer 1 ; -: ReplayPointer 2 ; -: AsyncKeyboard 3 ; -: SyncKeyboard 4 ; -: ReplayKeyboard 5 ; -: AsyncBoth 6 ; -: SyncBoth 7 ; +CONSTANT: AsyncPointer 0 +CONSTANT: SyncPointer 1 +CONSTANT: ReplayPointer 2 +CONSTANT: AsyncKeyboard 3 +CONSTANT: SyncKeyboard 4 +CONSTANT: ReplayKeyboard 5 +CONSTANT: AsyncBoth 6 +CONSTANT: SyncBoth 7 ! Used in SetInputFocus, GetInputFocus : RevertToNone ( -- n ) None ; : RevertToPointerRoot ( -- n ) PointerRoot ; -: RevertToParent 2 ; +CONSTANT: RevertToParent 2 ! ***************************************************************** ! * ERROR CODES ! ***************************************************************** -: Success 0 ; ! everything's okay -: BadRequest 1 ; ! bad request code -: BadValue 2 ; ! int parameter out of range -: BadWindow 3 ; ! parameter not a Window -: BadPixmap 4 ; ! parameter not a Pixmap -: BadAtom 5 ; ! parameter not an Atom -: BadCursor 6 ; ! parameter not a Cursor -: BadFont 7 ; ! parameter not a Font -: BadMatch 8 ; ! parameter mismatch -: BadDrawable 9 ; ! parameter not a Pixmap or Window -: BadAccess 10 ; ! depending on context: +CONSTANT: Success 0 ! everything's okay +CONSTANT: BadRequest 1 ! bad request code +CONSTANT: BadValue 2 ! int parameter out of range +CONSTANT: BadWindow 3 ! parameter not a Window +CONSTANT: BadPixmap 4 ! parameter not a Pixmap +CONSTANT: BadAtom 5 ! parameter not an Atom +CONSTANT: BadCursor 6 ! parameter not a Cursor +CONSTANT: BadFont 7 ! parameter not a Font +CONSTANT: BadMatch 8 ! parameter mismatch +CONSTANT: BadDrawable 9 ! parameter not a Pixmap or Window +CONSTANT: BadAccess 10 ! depending on context: ! - key/button already grabbed ! - attempt to free an illegal ! cmap entry @@ -154,16 +154,16 @@ TYPEDEF: uchar KeyCode ! color map entry. ! - attempt to modify the access control ! list from other than the local host. -: BadAlloc 11 ; ! insufficient resources -: BadColor 12 ; ! no such colormap -: BadGC 13 ; ! parameter not a GC -: BadIDChoice 14 ; ! choice not in range or already used -: BadName 15 ; ! font or color name doesn't exist -: BadLength 16 ; ! Request length incorrect -: BadImplementation 17 ; ! server is defective +CONSTANT: BadAlloc 11 ! insufficient resources +CONSTANT: BadColor 12 ! no such colormap +CONSTANT: BadGC 13 ! parameter not a GC +CONSTANT: BadIDChoice 14 ! choice not in range or already used +CONSTANT: BadName 15 ! font or color name doesn't exist +CONSTANT: BadLength 16 ! Request length incorrect +CONSTANT: BadImplementation 17 ! server is defective -: FirstExtensionError 128 ; -: LastExtensionError 255 ; +CONSTANT: FirstExtensionError 128 +CONSTANT: LastExtensionError 255 ! ***************************************************************** ! * WINDOW DEFINITIONS @@ -172,44 +172,44 @@ TYPEDEF: uchar KeyCode ! Window classes used by CreateWindow ! Note that CopyFromParent is already defined as 0 above -: InputOutput 1 ; -: InputOnly 2 ; +CONSTANT: InputOutput 1 +CONSTANT: InputOnly 2 ! Used in CreateWindow for backing-store hint -: NotUseful 0 ; -: WhenMapped 1 ; -: Always 2 ; +CONSTANT: NotUseful 0 +CONSTANT: WhenMapped 1 +CONSTANT: Always 2 ! Used in ChangeSaveSet -: SetModeInsert 0 ; -: SetModeDelete 1 ; +CONSTANT: SetModeInsert 0 +CONSTANT: SetModeDelete 1 ! Used in ChangeCloseDownMode -: DestroyAll 0 ; -: RetainPermanent 1 ; -: RetainTemporary 2 ; +CONSTANT: DestroyAll 0 +CONSTANT: RetainPermanent 1 +CONSTANT: RetainTemporary 2 ! Window stacking method (in configureWindow) -: Above 0 ; -: Below 1 ; -: TopIf 2 ; -: BottomIf 3 ; -: Opposite 4 ; +CONSTANT: Above 0 +CONSTANT: Below 1 +CONSTANT: TopIf 2 +CONSTANT: BottomIf 3 +CONSTANT: Opposite 4 ! Circulation direction -: RaiseLowest 0 ; -: LowerHighest 1 ; +CONSTANT: RaiseLowest 0 +CONSTANT: LowerHighest 1 ! Property modes -: PropModeReplace 0 ; -: PropModePrepend 1 ; -: PropModeAppend 2 ; +CONSTANT: PropModeReplace 0 +CONSTANT: PropModePrepend 1 +CONSTANT: PropModeAppend 2 ! ***************************************************************** ! * GRAPHICS DEFINITIONS @@ -217,62 +217,62 @@ TYPEDEF: uchar KeyCode ! LineStyle -: LineSolid 0 ; -: LineOnOffDash 1 ; -: LineDoubleDash 2 ; +CONSTANT: LineSolid 0 +CONSTANT: LineOnOffDash 1 +CONSTANT: LineDoubleDash 2 ! capStyle -: CapNotLast 0 ; -: CapButt 1 ; -: CapRound 2 ; -: CapProjecting 3 ; +CONSTANT: CapNotLast 0 +CONSTANT: CapButt 1 +CONSTANT: CapRound 2 +CONSTANT: CapProjecting 3 ! joinStyle -: JoinMiter 0 ; -: JoinRound 1 ; -: JoinBevel 2 ; +CONSTANT: JoinMiter 0 +CONSTANT: JoinRound 1 +CONSTANT: JoinBevel 2 ! fillStyle -: FillSolid 0 ; -: FillTiled 1 ; -: FillStippled 2 ; -: FillOpaqueStippled 3 ; +CONSTANT: FillSolid 0 +CONSTANT: FillTiled 1 +CONSTANT: FillStippled 2 +CONSTANT: FillOpaqueStippled 3 ! fillRule -: EvenOddRule 0 ; -: WindingRule 1 ; +CONSTANT: EvenOddRule 0 +CONSTANT: WindingRule 1 ! subwindow mode -: ClipByChildren 0 ; -: IncludeInferiors 1 ; +CONSTANT: ClipByChildren 0 +CONSTANT: IncludeInferiors 1 ! SetClipRectangles ordering -: Unsorted 0 ; -: YSorted 1 ; -: YXSorted 2 ; -: YXBanded 3 ; +CONSTANT: Unsorted 0 +CONSTANT: YSorted 1 +CONSTANT: YXSorted 2 +CONSTANT: YXBanded 3 ! CoordinateMode for drawing routines -: CoordModeOrigin 0 ; ! relative to the origin -: CoordModePrevious 1 ; ! relative to previous point +CONSTANT: CoordModeOrigin 0 ! relative to the origin +CONSTANT: CoordModePrevious 1 ! relative to previous point ! Polygon shapes -: Complex 0 ; ! paths may intersect -: Nonconvex 1 ; ! no paths intersect, but not convex -: Convex 2 ; ! wholly convex +CONSTANT: Complex 0 ! paths may intersect +CONSTANT: Nonconvex 1 ! no paths intersect, but not convex +CONSTANT: Convex 2 ! wholly convex ! Arc modes for PolyFillArc -: ArcChord 0 ; ! join endpoints of arc -: ArcPieSlice 1 ; ! join endpoints to center of arc +CONSTANT: ArcChord 0 ! join endpoints of arc +CONSTANT: ArcPieSlice 1 ! join endpoints to center of arc ! ***************************************************************** ! * FONTS @@ -280,10 +280,10 @@ TYPEDEF: uchar KeyCode ! used in QueryFont -- draw direction -: FontLeftToRight 0 ; -: FontRightToLeft 1 ; +CONSTANT: FontLeftToRight 0 +CONSTANT: FontRightToLeft 1 -: FontChange 255 ; +CONSTANT: FontChange 255 ! ***************************************************************** ! * IMAGING @@ -291,9 +291,9 @@ TYPEDEF: uchar KeyCode ! ImageFormat -- PutImage, GetImage -: XYBitmap 0 ; ! depth 1, XYFormat -: XYPixmap 1 ; ! depth == drawable depth -: ZPixmap 2 ; ! depth == drawable depth +CONSTANT: XYBitmap 0 ! depth 1, XYFormat +CONSTANT: XYPixmap 1 ! depth == drawable depth +CONSTANT: ZPixmap 2 ! depth == drawable depth ! ***************************************************************** ! * COLOR MAP STUFF @@ -301,8 +301,8 @@ TYPEDEF: uchar KeyCode ! For CreateColormap -: AllocNone 0 ; ! create map with no entries -: AllocAll 1 ; ! allocate entire map writeable +CONSTANT: AllocNone 0 ! create map with no entries +CONSTANT: AllocAll 1 ! allocate entire map writeable ! Flags used in StoreNamedColor, StoreColors @@ -317,20 +317,20 @@ TYPEDEF: uchar KeyCode ! QueryBestSize Class -: CursorShape 0 ; ! largest size that can be displayed -: TileShape 1 ; ! size tiled fastest -: StippleShape 2 ; ! size stippled fastest +CONSTANT: CursorShape 0 ! largest size that can be displayed +CONSTANT: TileShape 1 ! size tiled fastest +CONSTANT: StippleShape 2 ! size stippled fastest ! ***************************************************************** ! * KEYBOARD/POINTER STUFF ! ***************************************************************** -: AutoRepeatModeOff 0 ; -: AutoRepeatModeOn 1 ; -: AutoRepeatModeDefault 2 ; +CONSTANT: AutoRepeatModeOff 0 +CONSTANT: AutoRepeatModeOn 1 +CONSTANT: AutoRepeatModeDefault 2 -: LedModeOff 0 ; -: LedModeOn 1 ; +CONSTANT: LedModeOff 0 +CONSTANT: LedModeOn 1 ! masks for ChangeKeyboardControl @@ -343,33 +343,33 @@ TYPEDEF: uchar KeyCode : KBKey ( -- n ) 6 2^ ; : KBAutoRepeatMode ( -- n ) 7 2^ ; -: MappingSuccess 0 ; -: MappingBusy 1 ; -: MappingFailed 2 ; +CONSTANT: MappingSuccess 0 +CONSTANT: MappingBusy 1 +CONSTANT: MappingFailed 2 -: MappingModifier 0 ; -: MappingKeyboard 1 ; -: MappingPointer 2 ; +CONSTANT: MappingModifier 0 +CONSTANT: MappingKeyboard 1 +CONSTANT: MappingPointer 2 ! ***************************************************************** ! * SCREEN SAVER STUFF ! ***************************************************************** -: DontPreferBlanking 0 ; -: PreferBlanking 1 ; -: DefaultBlanking 2 ; +CONSTANT: DontPreferBlanking 0 +CONSTANT: PreferBlanking 1 +CONSTANT: DefaultBlanking 2 -: DisableScreenSaver 0 ; -: DisableScreenInterval 0 ; +CONSTANT: DisableScreenSaver 0 +CONSTANT: DisableScreenInterval 0 -: DontAllowExposures 0 ; -: AllowExposures 1 ; -: DefaultExposures 2 ; +CONSTANT: DontAllowExposures 0 +CONSTANT: AllowExposures 1 +CONSTANT: DefaultExposures 2 ! for ForceScreenSaver -: ScreenSaverReset 0 ; -: ScreenSaverActive 1 ; +CONSTANT: ScreenSaverReset 0 +CONSTANT: ScreenSaverActive 1 ! ***************************************************************** ! * HOSTS AND CONNECTIONS @@ -377,30 +377,30 @@ TYPEDEF: uchar KeyCode ! for ChangeHosts -: HostInsert 0 ; -: HostDelete 1 ; +CONSTANT: HostInsert 0 +CONSTANT: HostDelete 1 ! for ChangeAccessControl -: EnableAccess 1 ; -: DisableAccess 0 ; +CONSTANT: EnableAccess 1 +CONSTANT: DisableAccess 0 ! Display classes used in opening the connection ! Note that the statically allocated ones are even numbered and the ! dynamically changeable ones are odd numbered -: StaticGray 0 ; -: GrayScale 1 ; -: StaticColor 2 ; -: PseudoColor 3 ; -: TrueColor 4 ; -: DirectColor 5 ; +CONSTANT: StaticGray 0 +CONSTANT: GrayScale 1 +CONSTANT: StaticColor 2 +CONSTANT: PseudoColor 3 +CONSTANT: TrueColor 4 +CONSTANT: DirectColor 5 ! Byte order used in imageByteOrder and bitmapBitOrder -: LSBFirst 0 ; -: MSBFirst 1 ; +CONSTANT: LSBFirst 0 +CONSTANT: MSBFirst 1 ! ***************************************************************** ! * EXTENDED WINDOW MANAGER HINTS diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index 11473d6e83..e6001d3e59 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -9,23 +9,23 @@ IN: x11.glx LIBRARY: glx ! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib) -: GLX_USE_GL 1 ; ! support GLX rendering -: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer -: GLX_LEVEL 3 ; ! level in plane stacking -: GLX_RGBA 4 ; ! true if RGBA mode -: GLX_DOUBLEBUFFER 5 ; ! double buffering supported -: GLX_STEREO 6 ; ! stereo buffering supported -: GLX_AUX_BUFFERS 7 ; ! number of aux buffers -: GLX_RED_SIZE 8 ; ! number of red component bits -: GLX_GREEN_SIZE 9 ; ! number of green component bits -: GLX_BLUE_SIZE 10 ; ! number of blue component bits -: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits -: GLX_DEPTH_SIZE 12 ; ! number of depth bits -: GLX_STENCIL_SIZE 13 ; ! number of stencil bits -: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits -: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits -: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits -: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits +CONSTANT: GLX_USE_GL 1 ! support GLX rendering +CONSTANT: GLX_BUFFER_SIZE 2 ! depth of the color buffer +CONSTANT: GLX_LEVEL 3 ! level in plane stacking +CONSTANT: GLX_RGBA 4 ! true if RGBA mode +CONSTANT: GLX_DOUBLEBUFFER 5 ! double buffering supported +CONSTANT: GLX_STEREO 6 ! stereo buffering supported +CONSTANT: GLX_AUX_BUFFERS 7 ! number of aux buffers +CONSTANT: GLX_RED_SIZE 8 ! number of red component bits +CONSTANT: GLX_GREEN_SIZE 9 ! number of green component bits +CONSTANT: GLX_BLUE_SIZE 10 ! number of blue component bits +CONSTANT: GLX_ALPHA_SIZE 11 ! number of alpha component bits +CONSTANT: GLX_DEPTH_SIZE 12 ! number of depth bits +CONSTANT: GLX_STENCIL_SIZE 13 ! number of stencil bits +CONSTANT: GLX_ACCUM_RED_SIZE 14 ! number of red accum bits +CONSTANT: GLX_ACCUM_GREEN_SIZE 15 ! number of green accum bits +CONSTANT: GLX_ACCUM_BLUE_SIZE 16 ! number of blue accum bits +CONSTANT: GLX_ACCUM_ALPHA_SIZE 17 ! number of alpha accum bits TYPEDEF: XID GLXContextID TYPEDEF: XID GLXPixmap diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 534e47ac37..e06872fa83 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -34,7 +34,7 @@ SYMBOL: xim XNResourceClass over 0 XCreateIC [ "XCreateIC() failed" throw ] unless* ; -: buf-size 100 ; +CONSTANT: buf-size 100 SYMBOL: keybuf SYMBOL: keysym diff --git a/basis/xml/entities/entities.factor b/basis/xml/entities/entities.factor index 3e768b1b88..7eac725052 100644 --- a/basis/xml/entities/entities.factor +++ b/basis/xml/entities/entities.factor @@ -4,20 +4,20 @@ USING: namespaces make kernel assocs sequences fry values io.files io.encodings.binary xml.state ; IN: xml.entities -: entities-out +CONSTANT: entities-out H{ { CHAR: < "<" } { CHAR: > ">" } { CHAR: & "&" } - } ; + } -: quoted-entities-out +CONSTANT: quoted-entities-out H{ { CHAR: & "&" } { CHAR: ' "'" } { CHAR: " """ } { CHAR: < "<" } - } ; + } : escape-string-by ( str table -- escaped ) #! Convert <, >, &, ' and " to HTML entities. @@ -29,14 +29,14 @@ IN: xml.entities : escape-quoted-string ( str -- newstr ) quoted-entities-out escape-string-by ; -: entities +CONSTANT: entities H{ { "lt" CHAR: < } { "gt" CHAR: > } { "amp" CHAR: & } { "apos" CHAR: ' } { "quot" CHAR: " } - } ; + } : with-entities ( entities quot -- ) [ swap extra-entities set call ] with-scope ; inline diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index 304b38f2bd..35111f5a54 100644 --- a/basis/xml/errors/errors.factor +++ b/basis/xml/errors/errors.factor @@ -290,7 +290,7 @@ M: quoteless-attr summary TUPLE: attr-w/< < xml-error-at ; -: attr-w/< ( value -- * ) +: attr-w/< ( -- * ) \ attr-w/< xml-error-at throw ; M: attr-w/< summary @@ -299,7 +299,7 @@ M: attr-w/< summary TUPLE: text-w/]]> < xml-error-at ; -: text-w/]]> ( text -- * ) +: text-w/]]> ( -- * ) \ text-w/]]> xml-error-at throw ; M: text-w/]]> summary diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index f842d5f4cb..f22ca001f4 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -7,7 +7,7 @@ arrays words quotations accessors math.parser backtrack assocs ; IN: 24-game SYMBOL: commands -: nop ; +: nop ( -- ) ; : do-something ( a b -- c ) { + - * } amb-execute ; : maybe-swap ( a b -- a b ) { nop swap } amb-execute ; : some-rots ( a b c -- a b c ) diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor index df67872b11..0ae7d792dd 100755 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -10,7 +10,7 @@ IN: benchmark.backtrack ! placing them on the stack, and applying the operations ! +, -, * and rot as many times as we wish. -: nop ; +: nop ( -- ) ; : do-something ( a b -- c ) { + - * } amb-execute ; @@ -42,7 +42,7 @@ MEMO: 24-from-4 ( a b c d -- ? ) ] sigma ] sigma ; -: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; +CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 } : backtrack-benchmark ( -- ) words [ reset-memoized ] each diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 61d9e9fd43..2ae5ada8a1 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -10,8 +10,6 @@ CONSTANT: IC 29573 CONSTANT: initial-seed 42 CONSTANT: line-length 60 -USE: math.private - : random ( seed -- n seed ) >float IA * IC + IM mod [ IM /f ] keep ; inline @@ -19,7 +17,7 @@ HINTS: random fixnum ; CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" -: IUB +CONSTANT: IUB { { CHAR: a 0.27 } { CHAR: c 0.12 } @@ -37,15 +35,15 @@ CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC { CHAR: V 0.02 } { CHAR: W 0.02 } { CHAR: Y 0.02 } - } ; inline + } -: homo-sapiens +CONSTANT: homo-sapiens { { CHAR: a 0.3029549426680 } { CHAR: c 0.1979883004921 } { CHAR: g 0.1975473066391 } { CHAR: t 0.3015094502008 } - } ; inline + } : make-cumulative ( freq -- chars floats ) dup keys >byte-array diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8d07ae1c65..a4df1fe04d 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -8,13 +8,14 @@ hints ; IN: benchmark.raytracer ! parameters -: light - #! Normalized { -1 -3 2 }. + +! Normalized { -1 -3 2 }. +CONSTANT: light double-array{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 - } ; inline + } CONSTANT: oversampling 4 diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 20c905156b..d6e4f29b86 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -10,7 +10,7 @@ SYMBOL: counter SYMBOL: port-promise SYMBOL: server -: number-of-requests 1000 ; +CONSTANT: number-of-requests 1000 : server-addr ( -- addr ) "127.0.0.1" port-promise get ?promise ; diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index 259fa446af..ccba90fb6f 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: galois-talk -: galois-slides +CONSTANT: galois-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -305,7 +305,7 @@ IN: galois-talk "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : galois-talk ( -- ) galois-slides slides-window ; diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 8a10535306..254ed61ab0 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -121,12 +121,12 @@ CONSTANT: hat-switch-matching-hash : hat-switch? ( {usage-page,usage} -- ? ) { 1 HEX: 39 } = ; inline -: pov-values +CONSTANT: pov-values { pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left pov-neutral - } ; inline + } : button-value ( value -- f/(0,1] ) IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index 9bd3c5854b..4d4e3b0507 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: google-tech-talk -: google-slides +CONSTANT: google-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -562,7 +562,7 @@ IN: google-tech-talk "Put your prejudices aside and give it a shot!" } { $slide "Questions?" } -} ; +} : google-talk ( -- ) google-slides slides-window ; diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 0eba6f6af5..2770471093 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,7 +12,7 @@ IN: irc.client ! Setup and running objects ! ====================================== -: irc-port 6667 ; ! Default irc port +CONSTANT: irc-port 6667 ! Default irc port TUPLE: irc-profile server port nickname password ; C: irc-profile diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 59e4cf6cb4..791639d260 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -28,9 +28,9 @@ TUPLE: irc-tab < frame chat client window ; : write-color ( str color -- ) foreground associate format ; -: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; -: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; -: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ; +CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 } +CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 } +CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 } : dot-or-parens ( string -- string ) [ "." ] diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 9e457c7bdd..188095dd2e 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -5,8 +5,8 @@ calendar locals strings ui.gadgets.buttons combinators math.parser assocs threads ; IN: joystick-demo -: SIZE { 151 151 } ; -: INDICATOR-SIZE { 4 4 } ; +CONSTANT: SIZE { 151 151 } +CONSTANT: INDICATOR-SIZE { 4 4 } : FREQUENCY ( -- f ) 30 recip seconds ; TUPLE: axis-gadget < gadget indicator z-indicator pov ; @@ -21,7 +21,7 @@ M: axis-gadget pref-dim* drop SIZE ; : indicator-polygon ( -- polygon ) { 0 0 } INDICATOR-SIZE (rect-polygon) ; -: pov-polygons +CONSTANT: pov-polygons V{ { pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } } { pov-up { { 70 65 } { 75 60 } { 80 65 } } } @@ -32,7 +32,7 @@ M: axis-gadget pref-dim* drop SIZE ; { pov-down-left { { 67 90 } { 60 90 } { 60 83 } } } { pov-left { { 65 70 } { 60 75 } { 65 80 } } } { pov-up-left { { 67 60 } { 60 60 } { 60 67 } } } - } ; + } : ( color -- indicator ) indicator-polygon ; diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 05edb205d2..acf20f90ab 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -4,7 +4,7 @@ words arrays assocs math calendar fry alarms ui ui.gadgets.borders ui.gestures ; IN: key-caps -: key-locations H{ +CONSTANT: key-locations H{ { key-escape { { 0 0 } { 10 10 } } } { key-f1 { { 20 0 } { 10 10 } } } @@ -129,9 +129,9 @@ IN: key-caps { key-keypad-0 { { 190 55 } { 20 10 } } } { key-keypad-. { { 210 55 } { 10 10 } } } -} ; +} -: KEYBOARD-SIZE { 230 65 } ; +CONSTANT: KEYBOARD-SIZE { 230 65 } : FREQUENCY ( -- f ) 30 recip seconds ; TUPLE: key-caps-gadget < gadget keys alarm ; diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 849cc540a3..9877c70062 100755 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -42,7 +42,7 @@ SYMBOL: def-hash-keys set-alien-float alien-float } ; -: trivial-defs +: trivial-defs ( -- seq ) { [ drop ] [ 2array ] [ bitand ] diff --git a/extra/lisppaste/lisppaste.factor b/extra/lisppaste/lisppaste.factor index df85f01f26..43b5b78097 100644 --- a/extra/lisppaste/lisppaste.factor +++ b/extra/lisppaste/lisppaste.factor @@ -1,7 +1,7 @@ USING: arrays kernel xml-rpc ; IN: lisppaste -: url "http://www.common-lisp.net:8185/RPC2" ; +CONSTANT: url "http://www.common-lisp.net:8185/RPC2" : channels ( -- seq ) { } "listchannels" url invoke-method ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index ec0cbdbc9c..3cd38e1ff4 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -67,24 +67,24 @@ SYMBOL: stamp : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; -: load-everything-vocabs-file "load-everything-vocabs" ; -: load-everything-errors-file "load-everything-errors" ; +CONSTANT: load-everything-vocabs-file "load-everything-vocabs" +CONSTANT: load-everything-errors-file "load-everything-errors" -: test-all-vocabs-file "test-all-vocabs" ; -: test-all-errors-file "test-all-errors" ; +CONSTANT: test-all-vocabs-file "test-all-vocabs" +CONSTANT: test-all-errors-file "test-all-errors" -: help-lint-vocabs-file "help-lint-vocabs" ; -: help-lint-errors-file "help-lint-errors" ; +CONSTANT: help-lint-vocabs-file "help-lint-vocabs" +CONSTANT: help-lint-errors-file "help-lint-errors" -: boot-time-file "boot-time" ; -: load-time-file "load-time" ; -: compiler-errors-file "compiler-errors" ; -: test-time-file "test-time" ; -: help-lint-time-file "help-lint-time" ; -: benchmark-time-file "benchmark-time" ; -: html-help-time-file "html-help-time" ; +CONSTANT: boot-time-file "boot-time" +CONSTANT: load-time-file "load-time" +CONSTANT: compiler-errors-file "compiler-errors" +CONSTANT: test-time-file "test-time" +CONSTANT: help-lint-time-file "help-lint-time" +CONSTANT: benchmark-time-file "benchmark-time" +CONSTANT: html-help-time-file "html-help-time" -: benchmarks-file "benchmarks" ; +CONSTANT: benchmarks-file "benchmarks" SYMBOL: status diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index 9c773f748e..fa01b0376d 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -11,11 +11,11 @@ IN: math.analysis CONSTANT: gamma-g6 5.15 -: gamma-p6 +CONSTANT: gamma-p6 { 2.50662827563479526904 225.525584619175212544 -268.295973841304927459 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556 - } ; inline + } : gamma-z ( x n -- seq ) [ + recip ] with map 1.0 0 pick set-nth ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index de345e732e..a490a8bbfc 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -4,7 +4,7 @@ arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render math.order math.geometry.rect ; IN: maze -: line-width 8 ; +CONSTANT: line-width 8 SYMBOL: visited diff --git a/extra/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor index 25bad4061a..6f1df44bfb 100755 --- a/extra/minneapolis-talk/minneapolis-talk.factor +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -2,7 +2,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize ; IN: minneapolis-talk -: minneapolis-slides +CONSTANT: minneapolis-slides { { $slide "What is Factor?" "Dynamically typed, stack language" @@ -175,7 +175,7 @@ IN: minneapolis-talk "Mailing list: factor-talk@lists.sf.net" } { $slide "Questions?" } -} ; +} : minneapolis-talk ( -- ) minneapolis-slides slides-window ; diff --git a/extra/minneapolis-talk/minneapolis-talk.txt b/extra/minneapolis-talk/minneapolis-talk.txt deleted file mode 100755 index 5310accf5b..0000000000 --- a/extra/minneapolis-talk/minneapolis-talk.txt +++ /dev/null @@ -1,116 +0,0 @@ -- how to create a small module -- editor integration -- presentations -- module system -- copy and paste factoring, inverse -- help system -- tetris -- memoization -- editing inspector demo -- dynamic scope, lexical scope - -Factor: contradictions? ------------------------ - -Have our cake and eat it too - -Research -vs- practical -High level -vs- fast -Interactive -vs- deployment - -Factor from 10,000 feet ------------------------ - -word: named function -vocabulary: module -quotation: anonymous function -classes, objects, etc. - -The stack ---------- - -- Stack -vs- applicative -- Pass by reference, dynamically typed -- Stack languages: you can omit names where they're not needed -- More compositional style -- If you need to name things for clarity, you can: - lexical vars, dynamic vars, sequences, assocs, objects... - -Functional programming ----------------------- - -Quotations -Curry -Continuations - -Object-oriented programming ---------------------------- - -Generic words: sort of like open classes -Tuple reshaping -Editing inspector - -Meta programming ----------------- - -Simple, orthogonal core - -Why use a stack at all? ------------------------ - -Nice idioms: 10 days ago -Copy and paste factoring -Easy meta-programming -Sequence operations correspond to functional operations: -- curry is adding at the front -- compose is append - -UI --- - -Written in Factor -renders with OpenGL -Windows, X11, Cocoa backends -You can call Windows, X11, Cocoa APIs directly -OpenGL 2.1 shaders, OpenAL 3D audio... - -Tools ------ - -Edit -Usages -Profiler -Easy to make your own tools - -Implementation --------------- - -Two compilers -Generational garbage collector -Non-blocking I/O - -Hands on --------- - -Community ---------- - -Factor started in 2003 -About a dozen contributors -Handful of "core contributors" -Web site: http://factorcode.org -IRC: #concatenative on irc.freenode.net -Mailing list: factor-talk@lists.sf.net - -C library interface -------------------- - -Efficient -No need to write C code -Supports floats, structs, unions, ... -Function pointers, callbacks -Here is an example - -TerminateProcess - -process-handle TerminateProcess diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor index 29d4ccffc1..fdb53ef254 100644 --- a/extra/nehe/2/2.factor +++ b/extra/nehe/2/2.factor @@ -4,8 +4,8 @@ IN: nehe.2 TUPLE: nehe2-gadget < gadget ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : ( -- gadget ) nehe2-gadget new-gadget ; diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor index 75f2e573cc..557655a029 100644 --- a/extra/nehe/3/3.factor +++ b/extra/nehe/3/3.factor @@ -4,8 +4,8 @@ IN: nehe.3 TUPLE: nehe3-gadget < gadget ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : ( -- gadget ) nehe3-gadget new-gadget ; diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index fda22d2f1e..00308277ea 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -5,8 +5,8 @@ IN: nehe.4 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 30d0991fd8..3723014c83 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -4,8 +4,8 @@ calendar ; IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index b52749dbe1..ef5782dda7 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -39,7 +39,7 @@ M: png-gadget ungraft* ( gadget -- ) : $tetris ( element -- ) drop [ gadget. ] ($block) ; -: otug-slides +CONSTANT: otug-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -361,7 +361,7 @@ var price = (order == null ? null : order.price);"> } "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : otug-talk ( -- ) otug-slides slides-window ; diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 0ce946dc49..ba21ba9c84 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -6,7 +6,7 @@ ui.gadgets.books ui.gadgets.panes ui.gestures ui.render parser accessors colors ; IN: slides -: stylesheet +CONSTANT: stylesheet H{ { default-span-style H{ @@ -40,7 +40,7 @@ IN: slides H{ { table-gap { 10 20 } } } } { bullet "\u0000b7" } - } ; + } : $title ( string -- ) [ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ; diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 35d8bb52ff..5d7620101f 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: vpri-talk -: vpri-slides +CONSTANT: vpri-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -485,7 +485,7 @@ IN: vpri-talk "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : vpri-talk ( -- ) vpri-slides slides-window ; diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index b58a11747f..5e0c08b430 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -18,8 +18,7 @@ format similar-ok language country site subscription license ; first3 ] map ; -: yahoo-url ( -- str ) - URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ; +CONSTANT: yahoo-url URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" :: param ( search url name quot -- search url ) search url search quot call @@ -49,8 +48,7 @@ format similar-ok language country site subscription license ; "similar_ok" [ similar-ok>> ] bool-param nip ; -: factor-id - "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ; +CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" : ( query -- search ) search new diff --git a/unfinished/benchmark/richards/richards.factor b/unfinished/benchmark/richards/richards.factor deleted file mode 100644 index 90d4304eee..0000000000 --- a/unfinished/benchmark/richards/richards.factor +++ /dev/null @@ -1,272 +0,0 @@ -! Based on http://research.sun.com/people/mario/java_benchmarking/ -! Ported by Factor by Slava Pestov -! -! Based on original version written in BCPL by Dr Martin Richards -! in 1981 at Cambridge University Computer Laboratory, England -! Java version: Copyright (C) 1995 Sun Microsystems, Inc. -! by Jonathan Gibbons. -! Outer loop added 8/7/96 by Alex Jacoby -USING: values kernel accessors math math.bitwise sequences -arrays combinators fry locals ; -IN: benchmark.richards - -! Packets -TUPLE: packet link id kind a1 a2 ; - -: BUFSIZE 4 ; inline - -: ( link id kind -- packet ) - packet new - swap >>kind - swap >>id - swap >>link - 0 >>a1 - BUFSIZE 0 >>a2 ; - -: last-packet ( packet -- last ) - dup link>> [ last-packet ] [ ] ?if ; - -: append-to ( packet list -- packet ) - [ f >>link ] dip - [ tuck last-packet >>link drop ] when* ; - -! Tasks -: I_IDLE 1 ; inline -: I_WORK 2 ; inline -: I_HANDLERA 3 ; inline -: I_HANDLERB 4 ; inline -: I_DEVA 5 ; inline -: I_DEVB 6 ; inline - -! Packet types -: K_DEV 1000 ; inline -: K_WORK 1001 ; inline - -: PKTBIT 1 ; inline -: WAITBIT 2 ; inline -: HOLDBIT 4 ; inline - -: S_RUN 0 ; inline -: S_RUNPKT ( -- n ) { PKTBIT } flags ; inline -: S_WAIT ( -- n ) { WAITBIT } flags ; inline -: S_WAITPKT ( -- n ) { WAITBIT PKTBIT } flags ; inline -: S_HOLD ( -- n ) { HOLDBIT } flags ; inline -: S_HOLDPKT ( -- n ) { HOLDBIT PKTBIT } flags ; inline -: S_HOLDWAIT ( -- n ) { HOLDBIT WAITBIT } flags ; inline -: S_HOLDWAITPKT ( -- n ) { HOLDBIT WAITBIT PKTBIT } flags ; inline - -: task-tab-size 10 ; inline - -VALUE: task-tab -VALUE: task-list -VALUE: tracing -VALUE: hold-count -VALUE: qpkt-count - -TUPLE: task link id pri wkq state ; - -: new-task ( id pri wkq state class -- task ) - new - swap >>state - swap >>wkq - swap >>pri - swap >>id - task-list >>link - dup to: task-list - dup dup id>> task-tab set-nth ; inline - -GENERIC: fn ( packet task -- task ) - -: state-on ( task flag -- task ) - '[ _ bitor ] change-state ; inline - -: state-off ( task flag -- task ) - '[ _ bitnot bitand ] change-state ; inline - -: wait-task ( task -- task ) - WAITBIT state-on ; - -: hold ( task -- task ) - hold-count 1+ to: hold-count - HOLDBIT state-on - link>> ; - -: highest-priority ( t1 t2 -- t1/t2 ) - [ [ pri>> ] bi@ > ] most ; - -: find-tcb ( i -- task ) - task-tab nth [ "Bad task" throw ] unless* ; - -: release ( task i -- task ) - find-tcb HOLDBIT state-off highest-priority ; - -:: qpkt ( task pkt -- task ) - [let | t [ pkt id>> find-tcb ] | - t [ - qpkt-count 1+ to: qpkt-count - f pkt (>>link) - task id>> pkt (>>id) - t wkq>> [ - pkt t wkq>> append-to t (>>wkq) - task - ] [ - pkt t (>>wkq) - t PKTBIT state-on drop - t task highest-priority - ] if - ] [ task ] if - ] ; - -: schedule-waitpkt ( task -- task pkt ) - dup wkq>> - 2dup link>> >>wkq drop - 2dup S_RUNPKT S_RUN ? >>state drop ; inline - -: schedule-run ( task pkt -- task ) - swap fn ; inline - -: schedule-wait ( task -- task ) - link>> ; inline - -: (schedule) ( task -- ) - [ - dup state>> { - { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] } - { S_RUN [ f schedule-run (schedule) ] } - { S_RUNPKT [ f schedule-run (schedule) ] } - { S_WAIT [ schedule-wait (schedule) ] } - { S_HOLD [ schedule-wait (schedule) ] } - { S_HOLDPKT [ schedule-wait (schedule) ] } - { S_HOLDWAIT [ schedule-wait (schedule) ] } - { S_HOLDWAITPKT [ schedule-wait (schedule) ] } - [ 2drop ] - } case - ] when* ; - -: schedule ( -- ) - task-list (schedule) ; - -! Device task -TUPLE: device-task < task v1 ; - -: ( id pri wkq -- task ) - dup S_WAITPKT S_WAIT ? device-task new-task ; - -M:: device-task fn ( pkt task -- task ) - pkt [ - task dup v1>> - [ wait-task ] - [ [ f ] change-v1 swap qpkt ] if - ] [ pkt task (>>v1) task hold ] if ; - -TUPLE: handler-task < task workpkts devpkts ; - -: ( id pri wkq -- task ) - dup S_WAITPKT S_WAIT ? handler-task new-task ; - -M:: handler-task fn ( pkt task -- task ) - pkt [ - task over kind>> K_WORK = - [ [ append-to ] change-workpkts ] - [ [ append-to ] change-devpkts ] - if drop - ] when* - - task workpkts>> [ - [let* | devpkt [ task devpkts>> ] - workpkt [ task workpkts>> ] - count [ workpkt a1>> ] | - count BUFSIZE > [ - workpkt link>> task (>>workpkts) - task workpkt qpkt - ] [ - devpkt [ - devpkt link>> task (>>devpkts) - count workpkt a2>> nth devpkt (>>a1) - count 1+ workpkt (>>a1) - task devpkt qpkt - ] [ - task wait-task - ] if - ] if - ] - ] [ task wait-task ] if ; - -! Idle task -TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ; - -: ( i a1 a2 -- task ) - [ 0 f S_RUN idle-task new-task ] 2dip - [ >>v1 ] [ >>v2 ] bi* ; - -M: idle-task fn ( pkt task -- task ) - nip - [ 1- ] change-v2 - dup v2>> 0 = [ hold ] [ - dup v1>> 1 bitand 0 = [ - [ -1 shift ] change-v1 - I_DEVA release - ] [ - [ -1 shift HEX: d008 bitor ] change-v1 - I_DEVB release - ] if - ] if ; - -! Work task -TUPLE: work-task < task { handler fixnum } { n fixnum } ; - -: ( id pri w -- work-task ) - dup S_WAITPKT S_WAIT ? work-task new-task - I_HANDLERA >>handler - 0 >>n ; - -M:: work-task fn ( pkt task -- task ) - pkt [ - task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop - task handler>> pkt (>>id) - 0 pkt (>>a1) - BUFSIZE [| i | - task [ 1+ ] change-n drop - task n>> 26 > [ 1 task (>>n) ] when - task n>> 1 - CHAR: A + i pkt a2>> set-nth - ] each - task pkt qpkt - ] [ task wait-task ] if ; - -! Main -: init ( -- ) - task-tab-size f to: task-tab - f to: tracing - 0 to: hold-count - 0 to: qpkt-count ; - -: start ( -- ) - I_IDLE 1 10000 drop - - I_WORK 1000 - f 0 K_WORK 0 K_WORK - drop - - I_HANDLERA 2000 - f I_DEVA K_DEV - I_DEVA K_DEV - I_DEVA K_DEV - drop - - I_HANDLERB 3000 - f I_DEVB K_DEV - I_DEVB K_DEV - I_DEVB K_DEV - drop - - I_DEVA 4000 f drop - I_DEVB 4000 f drop ; - -: check ( -- ) - qpkt-count 23246 assert= - hold-count 9297 assert= ; - -: run ( -- ) - init - start - schedule check ; diff --git a/unfinished/sql/sql-tests.factor b/unfinished/sql/sql-tests.factor deleted file mode 100644 index 0b57c2d8fa..0000000000 --- a/unfinished/sql/sql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -USING: kernel namespaces db.sql sequences math ; -IN: db.sql.tests - -! TUPLE: person name age ; -: insert-1 - { insert - { - { table "person" } - { columns "name" "age" } - { values "erg" 26 } - } - } ; - -: update-1 - { update "person" - { set { "name" "erg" } - { "age" 6 } } - { where { "age" 6 } } - } ; - -: select-1 - { select - { columns - "branchno" - { count "staffno" as "mycount" } - { sum "salary" as "mysum" } } - { from "staff" "lol" } - { where - { "salary" > all - { select - { columns "salary" } - { from "staff" } - { where { "branchno" = "b003" } } - } - } - { "branchno" > 3 } } - { group-by "branchno" "lol2" } - { having { count "staffno" > 1 } } - { order-by "branchno" } - { offset 40 } - { limit 20 } - } ; diff --git a/unfinished/sql/sql.factor b/unfinished/sql/sql.factor deleted file mode 100755 index ba0673ae24..0000000000 --- a/unfinished/sql/sql.factor +++ /dev/null @@ -1,172 +0,0 @@ -USING: kernel parser quotations classes.tuple words math.order -nmake namespaces sequences arrays combinators -prettyprint strings math.parser math symbols db ; -IN: db.sql - -SYMBOLS: insert update delete select distinct columns from as -where group-by having order-by limit offset is-null desc all -any count avg table values ; - -: input-spec, ( obj -- ) 1, ; -: output-spec, ( obj -- ) 2, ; -: input, ( obj -- ) 3, ; -: output, ( obj -- ) 4, ; - -DEFER: sql% - -: (sql-interleave) ( seq sep -- ) - [ sql% ] curry [ sql% ] interleave ; - -: sql-interleave ( seq str sep -- ) - swap sql% (sql-interleave) ; - -: sql-function, ( seq function -- ) - sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; - -: sql-where, ( seq -- ) - [ - [ second 0, ] - [ first 0, ] - [ third 1, \ ? 0, ] tri - ] each ; - -HOOK: sql-create db ( object -- ) -M: db sql-create ( object -- ) - drop - "create table" sql% ; - -HOOK: sql-drop db ( object -- ) -M: db sql-drop ( object -- ) - drop - "drop table" sql% ; - -HOOK: sql-insert db ( object -- ) -M: db sql-insert ( object -- ) - drop - "insert into" sql% ; - -HOOK: sql-update db ( object -- ) -M: db sql-update ( object -- ) - drop - "update" sql% ; - -HOOK: sql-delete db ( object -- ) -M: db sql-delete ( object -- ) - drop - "delete" sql% ; - -HOOK: sql-select db ( object -- ) -M: db sql-select ( object -- ) - "select" sql% "," (sql-interleave) ; - -HOOK: sql-columns db ( object -- ) -M: db sql-columns ( object -- ) - "," (sql-interleave) ; - -HOOK: sql-from db ( object -- ) -M: db sql-from ( object -- ) - "from" "," sql-interleave ; - -HOOK: sql-where db ( object -- ) -M: db sql-where ( object -- ) - "where" 0, sql-where, ; - -HOOK: sql-group-by db ( object -- ) -M: db sql-group-by ( object -- ) - "group by" "," sql-interleave ; - -HOOK: sql-having db ( object -- ) -M: db sql-having ( object -- ) - "having" "," sql-interleave ; - -HOOK: sql-order-by db ( object -- ) -M: db sql-order-by ( object -- ) - "order by" "," sql-interleave ; - -HOOK: sql-offset db ( object -- ) -M: db sql-offset ( object -- ) - "offset" sql% sql% ; - -HOOK: sql-limit db ( object -- ) -M: db sql-limit ( object -- ) - "limit" sql% sql% ; - -! GENERIC: sql-subselect db ( object -- ) -! M: db sql-subselectselect ( object -- ) - ! "(select" sql% sql% ")" sql% ; - -HOOK: sql-table db ( object -- ) -M: db sql-table ( object -- ) - sql% ; - -HOOK: sql-set db ( object -- ) -M: db sql-set ( object -- ) - "set" "," sql-interleave ; - -HOOK: sql-values db ( object -- ) -M: db sql-values ( object -- ) - "values(" sql% "," (sql-interleave) ")" sql% ; - -HOOK: sql-count db ( object -- ) -M: db sql-count ( object -- ) - "count" sql-function, ; - -HOOK: sql-sum db ( object -- ) -M: db sql-sum ( object -- ) - "sum" sql-function, ; - -HOOK: sql-avg db ( object -- ) -M: db sql-avg ( object -- ) - "avg" sql-function, ; - -HOOK: sql-min db ( object -- ) -M: db sql-min ( object -- ) - "min" sql-function, ; - -HOOK: sql-max db ( object -- ) -M: db sql-max ( object -- ) - "max" sql-function, ; - -: sql-array% ( array -- ) - unclip - { - { \ create [ sql-create ] } - { \ drop [ sql-drop ] } - { \ insert [ sql-insert ] } - { \ update [ sql-update ] } - { \ delete [ sql-delete ] } - { \ select [ sql-select ] } - { \ columns [ sql-columns ] } - { \ from [ sql-from ] } - { \ where [ sql-where ] } - { \ group-by [ sql-group-by ] } - { \ having [ sql-having ] } - { \ order-by [ sql-order-by ] } - { \ offset [ sql-offset ] } - { \ limit [ sql-limit ] } - { \ table [ sql-table ] } - { \ set [ sql-set ] } - { \ values [ sql-values ] } - { \ count [ sql-count ] } - { \ sum [ sql-sum ] } - { \ avg [ sql-avg ] } - { \ min [ sql-min ] } - { \ max [ sql-max ] } - [ sql% [ sql% ] each ] - } case ; - -ERROR: no-sql-match ; -: sql% ( obj -- ) - { - { [ dup string? ] [ 0, ] } - { [ dup array? ] [ sql-array% ] } - { [ dup number? ] [ number>string sql% ] } - { [ dup symbol? ] [ unparse sql% ] } - { [ dup word? ] [ unparse sql% ] } - { [ dup quotation? ] [ call ] } - [ no-sql-match ] - } cond ; - -: parse-sql ( obj -- sql in-spec out-spec in out ) - [ [ sql% ] each ] { { } { } { } } nmake - [ " " join ] 2dip ; From 901bcccc1c6d70e5beeaf96cd0dc32ed40291d21 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 23:25:13 -0600 Subject: [PATCH 09/14] Fix remaining text failures --- basis/compiler/compiler.factor | 5 +---- basis/compiler/tests/optimizer.factor | 22 ++++++++++--------- basis/compiler/tests/simple.factor | 4 ++-- .../tree/cleanup/cleanup-tests.factor | 2 +- .../tree/recursive/recursive-tests.factor | 2 +- basis/tools/profiler/profiler-tests.factor | 2 +- 6 files changed, 18 insertions(+), 19 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d707dff983..f2f4e7aa9e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -49,7 +49,7 @@ SYMBOL: +failed+ H{ } clone generic-dependencies set f swap compiler-error ; -: fail ( word error -- * ) +: fail ( word error -- ) [ swap compiler-error ] [ drop @@ -112,9 +112,6 @@ t compile-dependencies? set-global : decompile ( word -- ) f 2array 1array modify-code-heap ; -: compile-call ( quot -- ) - [ dup infer define-temp ] with-compilation-unit execute ; - : optimized-recompile-hook ( words -- alist ) [ compile-queue set diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 708d17f3d3..cfeb5d01ac 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -55,7 +55,7 @@ TUPLE: pred-test ; ! regression -: literal-not-branch 0 not [ ] [ ] if ; +: literal-not-branch ( -- ) 0 not [ ] [ ] if ; [ ] [ literal-not-branch ] unit-test @@ -108,12 +108,12 @@ GENERIC: void-generic ( obj -- * ) [ 10 ] [ branch-fold-regression-1 ] unit-test ! another regression -: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-0 ( -- value ) "hey" ; foldable : constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test ! another regression -: foo f ; +: foo ( -- value ) f ; : bar ( -- ? ) foo 4 4 = and ; [ f ] [ bar ] unit-test @@ -134,15 +134,15 @@ M: slice foozul ; ] unit-test ! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable +: constant-fold-2 ( -- value ) f ; foldable +: constant-fold-3 ( -- value ) 4 ; foldable [ f t ] [ [ constant-fold-2 constant-fold-3 4 = ] compile-call ] unit-test -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable +: constant-fold-4 ( -- value ) f ; foldable +: constant-fold-5 ( -- value ) f ; foldable [ f ] [ [ constant-fold-4 constant-fold-5 or ] compile-call @@ -247,7 +247,7 @@ USE: binary-search.private [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test -: lift-loop-tail-test-1 ( a quot -- ) +: lift-loop-tail-test-1 ( a quot: ( -- ) -- ) over even? [ [ [ 3 - ] dip call ] keep lift-loop-tail-test-1 ] [ @@ -256,11 +256,13 @@ USE: binary-search.private ] [ [ [ 2 - ] dip call ] keep lift-loop-tail-test-1 ] if - ] if ; inline + ] if ; inline recursive -: lift-loop-tail-test-2 +: lift-loop-tail-test-2 ( -- a b c ) 10 [ ] lift-loop-tail-test-1 1 2 3 ; +\ lift-loop-tail-test-2 must-infer + [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test ! Forgot a recursive inline check diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 0fde270eac..d53b864b06 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -18,13 +18,13 @@ IN: compiler.tests [ "hey" ] [ [ "hey" ] compile-call ] unit-test ! Calls -: no-op ; +: no-op ( -- ) ; [ ] [ [ no-op ] compile-call ] unit-test [ 3 ] [ [ no-op 3 ] compile-call ] unit-test [ 3 ] [ [ 3 no-op ] compile-call ] unit-test -: bar 4 ; +: bar ( -- value ) 4 ; [ 4 ] [ [ bar no-op ] compile-call ] unit-test [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 751a335a13..54f8aaf20e 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -474,7 +474,7 @@ cell-bits 32 = [ ] unit-test ! A reduction -: buffalo-sauce f ; +: buffalo-sauce ( -- value ) f ; : steak ( -- ) buffalo-sauce [ steak ] when ; inline recursive diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index b1f9406092..d548d58bc6 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -87,7 +87,7 @@ compiler.tree.combinators ; ] contains-node? ] unit-test -: blah f ; +: blah ( -- value ) f ; DEFER: a diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 197ace74d8..5bf62ef156 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -1,6 +1,6 @@ IN: tools.profiler.tests USING: accessors tools.profiler tools.test kernel memory math -threads alien tools.profiler.private sequences compiler.units +threads alien tools.profiler.private sequences compiler words ; [ t ] [ From e7243da0b80dda06cfea3e55954431a7c70b8fb7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 23:28:02 -0600 Subject: [PATCH 10/14] Clean up memoize code to not use gensym anymore --- basis/macros/macros.factor | 4 +- basis/memoize/memoize-tests.factor | 8 ++- basis/memoize/memoize.factor | 67 ++++++++++++------------- basis/tools/deploy/shaker/shaker.factor | 2 +- 4 files changed, 41 insertions(+), 40 deletions(-) diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 4fba7efba3..21a91e567d 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; @@ -7,7 +7,7 @@ IN: macros > 1 ; + stack-effect in>> 1 ; PRIVATE> diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 7ee56866ce..03549d9b80 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser generalizations prettyprint io.streams.string sequences eval ; @@ -17,6 +17,10 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test + +[ sq ] (( a -- b )) memoize-quot "q" set + +[ 9 ] [ 3 "q" get call ] unit-test diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 7b8c30c534..3bc573dff5 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -1,47 +1,45 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel hashtables sequences arrays words namespaces make parser math assocs effects definitions quotations summary -accessors ; +accessors fry ; IN: memoize -: packer ( n -- quot ) - { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; - -: unpacker ( n -- quot ) - { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; - -: #in ( word -- n ) - stack-effect in>> length ; - -: #out ( word -- n ) - stack-effect out>> length ; - -: pack/unpack ( quot word -- newquot ) - [ dup #in unpacker % swap % #out packer % ] [ ] make ; - -: make-memoizer ( quot word -- quot ) - [ - [ #in packer % ] keep - [ "memoize" word-prop , ] keep - [ pack/unpack , ] keep - \ cache , - #out unpacker % - ] [ ] make ; - ERROR: too-many-arguments ; M: too-many-arguments summary drop "There must be no more than 4 input and 4 output arguments" ; -: check-memoized ( word -- ) - [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ; +> packer ] [ out>> unpacker ] bi surround ; + +: unpack/pack ( quot effect -- newquot ) + [ in>> unpacker ] [ out>> packer ] bi surround ; + +: check-memoized ( effect -- ) + [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ; + +: make-memoizer ( table quot effect -- quot ) + [ check-memoized ] keep + [ unpack/pack '[ _ _ cache ] ] keep + pack/unpack ; + +PRIVATE> : define-memoized ( word quot -- ) - over check-memoized - 2dup "memo-quot" set-word-prop - over H{ } clone "memoize" set-word-prop - over make-memoizer define ; + [ H{ } clone ] dip + [ pick stack-effect make-memoizer define ] + [ nip "memo-quot" set-word-prop ] + [ drop "memoize" set-word-prop ] + 3tri ; : MEMO: (:) define-memoized ; parsing @@ -57,11 +55,10 @@ M: memoized reset-word bi ; : memoize-quot ( quot effect -- memo-quot ) - gensym swap dupd "declared-effect" set-word-prop - dup rot define-memoized 1quotation ; + [ H{ } clone ] 2dip make-memoizer ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; : invalidate-memoized ( inputs... word -- ) - [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; + [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e61021e633..5095f9e93e 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -190,7 +190,7 @@ IN: tools.deploy.shaker "Stripping default methods" show [ [ generic? ] instances - [ "No method" throw ] (( -- * )) define-temp + [ "No method" throw ] define-temp dup t "default" set-word-prop '[ [ _ "default-method" set-word-prop ] [ make-generic ] bi From b06903b0efc727bcce5c7269aa033cf94dcc2400 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 23:28:22 -0600 Subject: [PATCH 11/14] Update tree shaker for define-temp changes --- basis/tools/deploy/shaker/shaker.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5095f9e93e..961d0ff26d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -95,7 +95,7 @@ IN: tools.deploy.shaker "cannot-infer" "coercer" "combination" - "compiled-effect" + "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" @@ -190,7 +190,7 @@ IN: tools.deploy.shaker "Stripping default methods" show [ [ generic? ] instances - [ "No method" throw ] define-temp + [ "No method" throw ] (( -- * )) define-temp dup t "default" set-word-prop '[ [ _ "default-method" set-word-prop ] [ make-generic ] bi From 65a53e1fa5fa120988ec108ed57358bba221c94a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Feb 2009 23:55:16 -0600 Subject: [PATCH 12/14] Don't keep compiled-effect around anymore --- basis/compiler/cfg/debugger/debugger.factor | 2 +- basis/compiler/compiler.factor | 62 ++++++++++--------- basis/compiler/tests/optimizer.factor | 2 +- .../tree/builder/builder-tests.factor | 2 +- basis/compiler/tree/builder/builder.factor | 8 +-- basis/compiler/tree/debugger/debugger.factor | 2 +- 6 files changed, 41 insertions(+), 37 deletions(-) diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index ba58e60a4a..6d0a8f8c8e 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -16,7 +16,7 @@ M: callable test-cfg build-tree optimize-tree gensym build-cfg ; M: word test-cfg - [ build-tree-from-word nip optimize-tree ] keep build-cfg ; + [ build-tree-from-word optimize-tree ] keep build-cfg ; SYMBOL: allocate-registers? diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index f2f4e7aa9e..d6da95408d 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,46 +1,47 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces arrays sequences io -words fry continuations vocabs assocs dlists definitions math -graphs generic combinators deques search-deques io -stack-checker stack-checker.state stack-checker.inlining -compiler.errors compiler.units compiler.tree.builder -compiler.tree.optimizer compiler.cfg.builder -compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +USING: accessors kernel namespaces arrays sequences io words fry +continuations vocabs assocs dlists definitions math graphs +generic combinators deques search-deques io stack-checker +stack-checker.state stack-checker.inlining +combinators.short-circuit compiler.errors compiler.units +compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame +compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue SYMBOL: compiled -: queue-compile ( word -- ) +: queue-compile? ( word -- ? ) { - { [ dup "forgotten" word-prop ] [ ] } - { [ dup compiled get key? ] [ ] } - { [ dup inlined-block? ] [ ] } - { [ dup primitive? ] [ ] } - [ dup compile-queue get push-front ] - } cond drop ; + [ "forgotten" word-prop ] + [ compiled get key? ] + [ inlined-block? ] + [ primitive? ] + } 1|| not ; + +: queue-compile ( word -- ) + dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; : maybe-compile ( word -- ) dup optimized>> [ drop ] [ queue-compile ] if ; -SYMBOL: +failed+ +SYMBOLS: +optimized+ +unoptimized+ ; : ripple-up ( words -- ) - dup "compiled-effect" word-prop +failed+ eq? + dup "compiled-status" word-prop +unoptimized+ eq? [ usage [ word? ] filter ] [ compiled-usage keys ] if [ queue-compile ] each ; -: ripple-up? ( word effect -- ? ) - #! If the word has previously been compiled and had a - #! different stack effect, we have to recompile any callers. - swap "compiled-effect" word-prop [ = not ] keep and ; +: ripple-up? ( word status -- ? ) + swap "compiled-status" word-prop [ = not ] keep and ; -: save-effect ( word effect -- ) +: save-compiled-status ( word status -- ) [ dupd ripple-up? [ ripple-up ] [ drop ] if ] - [ "compiled-effect" set-word-prop ] + [ "compiled-status" set-word-prop ] 2bi ; : start ( word -- ) @@ -49,18 +50,18 @@ SYMBOL: +failed+ H{ } clone generic-dependencies set f swap compiler-error ; -: fail ( word error -- ) +: fail ( word error -- * ) [ swap compiler-error ] [ drop [ compiled-unxref ] [ f swap compiled get set-at ] - [ +failed+ save-effect ] + [ +unoptimized+ save-compiled-status ] tri ] 2bi return ; -: frontend ( word -- effect nodes ) +: frontend ( word -- nodes ) [ build-tree-from-word ] [ fail ] recover optimize-tree ; ! Only switch this off for debugging. @@ -84,8 +85,8 @@ t compile-dependencies? set-global save-asm ] each ; -: finish ( effect word -- ) - [ swap save-effect ] +: finish ( word -- ) + [ +optimized+ save-compiled-status ] [ compiled-unxref ] [ dup crossref? @@ -112,6 +113,9 @@ t compile-dependencies? set-global : decompile ( word -- ) f 2array 1array modify-code-heap ; +: compile-call ( quot -- ) + [ dup infer define-temp ] with-compilation-unit execute ; + : optimized-recompile-hook ( words -- alist ) [ compile-queue set diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index cfeb5d01ac..b5cb0ddbdb 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -303,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; \ member-test must-infer -[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test +[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index d758e2a34d..4982a3986c 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -8,4 +8,4 @@ compiler.tree ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test +[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index b715223445..4cb7650b1d 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -12,18 +12,18 @@ IN: compiler.tree.builder : with-tree-builder ( quot -- nodes ) '[ V{ } clone stack-visitor set @ ] - with-infer ; inline + with-infer nip ; inline : build-tree ( quot -- nodes ) #! Not safe to call from inference transforms. - [ f initial-recursive-state infer-quot ] with-tree-builder nip ; + [ f initial-recursive-state infer-quot ] with-tree-builder ; : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ [ >vector \ meta-d set ] [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder nip + ] with-tree-builder unclip-last in-d>> ; : build-sub-tree ( #call quot -- nodes ) @@ -45,7 +45,7 @@ IN: compiler.tree.builder : check-no-compile ( word -- ) dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; -: build-tree-from-word ( word -- effect nodes ) +: build-tree-from-word ( word -- nodes ) [ [ { diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 9f2cc0536e..188dcdb935 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -144,7 +144,7 @@ SYMBOL: node-count : make-report ( word/quot -- assoc ) [ - dup word? [ build-tree-from-word nip ] [ build-tree ] if + dup word? [ build-tree-from-word ] [ build-tree ] if optimize-tree H{ } clone words-called set From b8ed7d20de7b33c20d8308db151355f4ae5519fd Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 02:46:29 -0600 Subject: [PATCH 13/14] Update Windows-specific code for stricter stack checking --- basis/ui/windows/windows.factor | 14 +++++++------- basis/windows/winsock/winsock.factor | 5 ++--- 2 files changed, 9 insertions(+), 10 deletions(-) mode change 100644 => 100755 basis/windows/winsock/winsock.factor diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index c22fcb6cbe..9df694ee37 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -104,7 +104,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; [ lo-word ] keep hi-word 2array swap window (>>window-loc) ; -: wm-keydown-codes ( -- key ) +CONSTANT: wm-keydown-codes H{ { 8 "BACKSPACE" } { 9 "TAB" } @@ -132,7 +132,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; { 121 "F10" } { 122 "F11" } { 123 "F12" } - } ; + } : key-state-down? ( key -- ? ) GetKeyState 16 bit? ; @@ -155,22 +155,22 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; alt? [ A+ , ] when ] { } make [ empty? not ] keep f ? ; -: exclude-keys-wm-keydown +CONSTANT: exclude-keys-wm-keydown H{ { 16 "SHIFT" } { 17 "CTRL" } { 18 "ALT" } { 20 "CAPS-LOCK" } - } ; + } -: exclude-keys-wm-char - ! Values are ignored +! Values are ignored +CONSTANT: exclude-keys-wm-char H{ { 8 "BACKSPACE" } { 9 "TAB" } { 13 "RET" } { 27 "ESC" } - } ; + } : exclude-key-wm-keydown? ( n -- ? ) exclude-keys-wm-keydown key? ; diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor old mode 100644 new mode 100755 index 27069ed743..06df74cd4c --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -257,12 +257,11 @@ TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO -: FD_MAX_EVENTS 10 ; +CONSTANT: FD_MAX_EVENTS 10 C-STRUCT: WSANETWORKEVENTS { "long" "lNetworkEvents" } - ! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ; - { { "int" 10 } "iErrorCode" } ; + { { "int" FD_MAX_EVENTS } "iErrorCode" } ; TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS From e8361b99806c781e7c966e6e7fb7dafb272316dc Mon Sep 17 00:00:00 2001 From: slava Date: Tue, 24 Feb 2009 01:06:50 -0600 Subject: [PATCH 14/14] Updating X11 UI backend for stricter stack effect checking --- basis/ui/x11/x11.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 34cff42777..d0d7eeb234 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -29,14 +29,14 @@ M: world configure-event ! In case dimensions didn't change relayout-1 ; -: modifiers +CONSTANT: modifiers { { S+ HEX: 1 } { C+ HEX: 4 } { A+ HEX: 8 } - } ; - -: key-codes + } + +CONSTANT: key-codes H{ { HEX: FF08 "BACKSPACE" } { HEX: FF09 "TAB" } @@ -62,7 +62,7 @@ M: world configure-event { HEX: FFC4 "F7" } { HEX: FFC5 "F8" } { HEX: FFC6 "F9" } - } ; + } : key-code ( keysym -- keycode action? ) dup key-codes at [ t ] [ 1string f ] ?if ;