From b974133285990ffb7ffc9e427c3503bc08b42281 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Tue, 3 Jun 2008 11:01:04 +1200
Subject: [PATCH 01/85] Re-add jni library to unmaintained
---
unmaintained/jni/jni-internals.factor | 357 ++++++++++++++++++++++++++
unmaintained/jni/jni.factor | 22 ++
unmaintained/jni/load.factor | 4 +
3 files changed, 383 insertions(+)
create mode 100644 unmaintained/jni/jni-internals.factor
create mode 100644 unmaintained/jni/jni.factor
create mode 100644 unmaintained/jni/load.factor
diff --git a/unmaintained/jni/jni-internals.factor b/unmaintained/jni/jni-internals.factor
new file mode 100644
index 0000000000..49bc57b108
--- /dev/null
+++ b/unmaintained/jni/jni-internals.factor
@@ -0,0 +1,357 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+IN: jni-internals
+USING: kernel alien arrays sequences ;
+
+LIBRARY: jvm
+
+TYPEDEF: int jint
+TYPEDEF: uchar jboolean
+TYPEDEF: void* JNIEnv
+
+C-STRUCT: jdk-init-args
+ { "jint" "version" }
+ { "void*" "properties" }
+ { "jint" "check-source" }
+ { "jint" "native-stack-size" }
+ { "jint" "java-stack-size" }
+ { "jint" "min-heap-size" }
+ { "jint" "max-heap-size" }
+ { "jint" "verify-mode" }
+ { "char*" "classpath" }
+ { "void*" "vprintf" }
+ { "void*" "exit" }
+ { "void*" "abort" }
+ { "jint" "enable-class-gc" }
+ { "jint" "enable-verbose-gc" }
+ { "jint" "disable-async-gc" }
+ { "jint" "verbose" }
+ { "jboolean" "debugging" }
+ { "jint" "debug-port" } ;
+
+C-STRUCT: JNIInvokeInterface
+ { "void*" "reserved0" }
+ { "void*" "reserved1" }
+ { "void*" "reserved2" }
+ { "void*" "DestroyJavaVM" }
+ { "void*" "AttachCurrentThread" }
+ { "void*" "DetachCurrentThread" }
+ { "void*" "GetEnv" }
+ { "void*" "AttachCurrentThreadAsDaemon" } ;
+
+C-STRUCT: JavaVM
+ { "JNIInvokeInterface*" "functions" } ;
+
+C-STRUCT: JNINativeInterface
+ { "void*" "reserved0" }
+ { "void*" "reserved1" }
+ { "void*" "reserved2" }
+ { "void*" "reserved3" }
+ { "void*" "GetVersion" }
+ { "void*" "DefineClass" }
+ { "void*" "FindClass" }
+ { "void*" "FromReflectedMethod" }
+ { "void*" "FromReflectedField" }
+ { "void*" "ToReflectedMethod" }
+ { "void*" "GetSuperclass" }
+ { "void*" "IsAssignableFrom" }
+ { "void*" "ToReflectedField" }
+ { "void*" "Throw" }
+ { "void*" "ThrowNew" }
+ { "void*" "ExceptionOccurred" }
+ { "void*" "ExceptionDescribe" }
+ { "void*" "ExceptionClear" }
+ { "void*" "FatalError" }
+ { "void*" "PushLocalFrame" }
+ { "void*" "PopLocalFrame" }
+ { "void*" "NewGlobalRef" }
+ { "void*" "DeleteGlobalRef" }
+ { "void*" "DeleteLocalRef" }
+ { "void*" "IsSameObject" }
+ { "void*" "NewLocalRef" }
+ { "void*" "EnsureLocalCapacity" }
+ { "void*" "AllocObject" }
+ { "void*" "NewObject" }
+ { "void*" "NewObjectV" }
+ { "void*" "NewObjectA" }
+ { "void*" "GetObjectClass" }
+ { "void*" "IsInstanceOf" }
+ { "void*" "GetMethodID" }
+ { "void*" "CallObjectMethod" }
+ { "void*" "CallObjectMethodV" }
+ { "void*" "CallObjectMethodA" }
+ { "void*" "CallBooleanMethod" }
+ { "void*" "CallBooleanMethodV" }
+ { "void*" "CallBooleanMethodA" }
+ { "void*" "CallByteMethod" }
+ { "void*" "CallByteMethodV" }
+ { "void*" "CallByteMethodA" }
+ { "void*" "CallCharMethod" }
+ { "void*" "CallCharMethodV" }
+ { "void*" "CallCharMethodA" }
+ { "void*" "CallShortMethod" }
+ { "void*" "CallShortMethodV" }
+ { "void*" "CallShortMethodA" }
+ { "void*" "CallIntMethod" }
+ { "void*" "CallIntMethodV" }
+ { "void*" "CallIntMethodA" }
+ { "void*" "CallLongMethod" }
+ { "void*" "CallLongMethodV" }
+ { "void*" "CallLongMethodA" }
+ { "void*" "CallFloatMethod" }
+ { "void*" "CallFloatMethodV" }
+ { "void*" "CallFloatMethodA" }
+ { "void*" "CallDoubleMethod" }
+ { "void*" "CallDoubleMethodV" }
+ { "void*" "CallDoubleMethodA" }
+ { "void*" "CallVoidMethod" }
+ { "void*" "CallVoidMethodV" }
+ { "void*" "CallVoidMethodA" }
+ { "void*" "CallNonvirtualObjectMethod" }
+ { "void*" "CallNonvirtualObjectMethodV" }
+ { "void*" "CallNonvirtualObjectMethodA" }
+ { "void*" "CallNonvirtualBooleanMethod" }
+ { "void*" "CallNonvirtualBooleanMethodV" }
+ { "void*" "CallNonvirtualBooleanMethodA" }
+ { "void*" "CallNonvirtualByteMethod" }
+ { "void*" "CallNonvirtualByteMethodV" }
+ { "void*" "CallNonvirtualByteMethodA" }
+ { "void*" "CallNonvirtualCharMethod" }
+ { "void*" "CallNonvirtualCharMethodV" }
+ { "void*" "CallNonvirtualCharMethodA" }
+ { "void*" "CallNonvirtualShortMethod" }
+ { "void*" "CallNonvirtualShortMethodV" }
+ { "void*" "CallNonvirtualShortMethodA" }
+ { "void*" "CallNonvirtualIntMethod" }
+ { "void*" "CallNonvirtualIntMethodV" }
+ { "void*" "CallNonvirtualIntMethodA" }
+ { "void*" "CallNonvirtualLongMethod" }
+ { "void*" "CallNonvirtualLongMethodV" }
+ { "void*" "CallNonvirtualLongMethodA" }
+ { "void*" "CallNonvirtualFloatMethod" }
+ { "void*" "CallNonvirtualFloatMethodV" }
+ { "void*" "CallNonvirtualFloatMethodA" }
+ { "void*" "CallNonvirtualDoubleMethod" }
+ { "void*" "CallNonvirtualDoubleMethodV" }
+ { "void*" "CallNonvirtualDoubleMethodA" }
+ { "void*" "CallNonvirtualVoidMethod" }
+ { "void*" "CallNonvirtualVoidMethodV" }
+ { "void*" "CallNonvirtualVoidMethodA" }
+ { "void*" "GetFieldID" }
+ { "void*" "GetObjectField" }
+ { "void*" "GetBooleanField" }
+ { "void*" "GetByteField" }
+ { "void*" "GetCharField" }
+ { "void*" "GetShortField" }
+ { "void*" "GetIntField" }
+ { "void*" "GetLongField" }
+ { "void*" "GetFloatField" }
+ { "void*" "GetDoubleField" }
+ { "void*" "SetObjectField" }
+ { "void*" "SetBooleanField" }
+ { "void*" "SetByteField" }
+ { "void*" "SetCharField" }
+ { "void*" "SetShortField" }
+ { "void*" "SetIntField" }
+ { "void*" "SetLongField" }
+ { "void*" "SetFloatField" }
+ { "void*" "SetDoubleField" }
+ { "void*" "GetStaticMethodID" }
+ { "void*" "CallStaticObjectMethod" }
+ { "void*" "CallStaticObjectMethodV" }
+ { "void*" "CallStaticObjectMethodA" }
+ { "void*" "CallStaticBooleanMethod" }
+ { "void*" "CallStaticBooleanMethodV" }
+ { "void*" "CallStaticBooleanMethodA" }
+ { "void*" "CallStaticByteMethod" }
+ { "void*" "CallStaticByteMethodV" }
+ { "void*" "CallStaticByteMethodA" }
+ { "void*" "CallStaticCharMethod" }
+ { "void*" "CallStaticCharMethodV" }
+ { "void*" "CallStaticCharMethodA" }
+ { "void*" "CallStaticShortMethod" }
+ { "void*" "CallStaticShortMethodV" }
+ { "void*" "CallStaticShortMethodA" }
+ { "void*" "CallStaticIntMethod" }
+ { "void*" "CallStaticIntMethodV" }
+ { "void*" "CallStaticIntMethodA" }
+ { "void*" "CallStaticLongMethod" }
+ { "void*" "CallStaticLongMethodV" }
+ { "void*" "CallStaticLongMethodA" }
+ { "void*" "CallStaticFloatMethod" }
+ { "void*" "CallStaticFloatMethodV" }
+ { "void*" "CallStaticFloatMethodA" }
+ { "void*" "CallStaticDoubleMethod" }
+ { "void*" "CallStaticDoubleMethodV" }
+ { "void*" "CallStaticDoubleMethodA" }
+ { "void*" "CallStaticVoidMethod" }
+ { "void*" "CallStaticVoidMethodV" }
+ { "void*" "CallStaticVoidMethodA" }
+ { "void*" "GetStaticFieldID" }
+ { "void*" "GetStaticObjectField" }
+ { "void*" "GetStaticBooleanField" }
+ { "void*" "GetStaticByteField" }
+ { "void*" "GetStaticCharField" }
+ { "void*" "GetStaticShortField" }
+ { "void*" "GetStaticIntField" }
+ { "void*" "GetStaticLongField" }
+ { "void*" "GetStaticFloatField" }
+ { "void*" "GetStaticDoubleField" }
+ { "void*" "SetStaticObjectField" }
+ { "void*" "SetStaticBooleanField" }
+ { "void*" "SetStaticByteField" }
+ { "void*" "SetStaticCharField" }
+ { "void*" "SetStaticShortField" }
+ { "void*" "SetStaticIntField" }
+ { "void*" "SetStaticLongField" }
+ { "void*" "SetStaticFloatField" }
+ { "void*" "SetStaticDoubleField" }
+ { "void*" "NewString" }
+ { "void*" "GetStringLength" }
+ { "void*" "GetStringChars" }
+ { "void*" "ReleaseStringChars" }
+ { "void*" "NewStringUTF" }
+ { "void*" "GetStringUTFLength" }
+ { "void*" "GetStringUTFChars" }
+ { "void*" "ReleaseStringUTFChars" }
+ { "void*" "GetArrayLength" }
+ { "void*" "NewObjectArray" }
+ { "void*" "GetObjectArrayElement" }
+ { "void*" "SetObjectArrayElement" }
+ { "void*" "NewBooleanArray" }
+ { "void*" "NewByteArray" }
+ { "void*" "NewCharArray" }
+ { "void*" "NewShortArray" }
+ { "void*" "NewIntArray" }
+ { "void*" "NewLongArray" }
+ { "void*" "NewFloatArray" }
+ { "void*" "NewDoubleArray" }
+ { "void*" "GetBooleanArrayElements" }
+ { "void*" "GetByteArrayElements" }
+ { "void*" "GetCharArrayElements" }
+ { "void*" "GetShortArrayElements" }
+ { "void*" "GetIntArrayElements" }
+ { "void*" "GetLongArrayElements" }
+ { "void*" "GetFloatArrayElements" }
+ { "void*" "GetDoubleArrayElements" }
+ { "void*" "ReleaseBooleanArrayElements" }
+ { "void*" "ReleaseByteArrayElements" }
+ { "void*" "ReleaseCharArrayElements" }
+ { "void*" "ReleaseShortArrayElements" }
+ { "void*" "ReleaseIntArrayElements" }
+ { "void*" "ReleaseLongArrayElements" }
+ { "void*" "ReleaseFloatArrayElements" }
+ { "void*" "ReleaseDoubleArrayElements" }
+ { "void*" "GetBooleanArrayRegion" }
+ { "void*" "GetByteArrayRegion" }
+ { "void*" "GetCharArrayRegion" }
+ { "void*" "GetShortArrayRegion" }
+ { "void*" "GetIntArrayRegion" }
+ { "void*" "GetLongArrayRegion" }
+ { "void*" "GetFloatArrayRegion" }
+ { "void*" "GetDoubleArrayRegion" }
+ { "void*" "SetBooleanArrayRegion" }
+ { "void*" "SetByteArrayRegion" }
+ { "void*" "SetCharArrayRegion" }
+ { "void*" "SetShortArrayRegion" }
+ { "void*" "SetIntArrayRegion" }
+ { "void*" "SetLongArrayRegion" }
+ { "void*" "SetFloatArrayRegion" }
+ { "void*" "SetDoubleArrayRegion" }
+ { "void*" "RegisterNatives" }
+ { "void*" "UnregisterNatives" }
+ { "void*" "MonitorEnter" }
+ { "void*" "MonitorExit" }
+ { "void*" "GetJavaVM" }
+ { "void*" "GetStringRegion" }
+ { "void*" "GetStringUTFRegion" }
+ { "void*" "GetPrimitiveArrayCritical" }
+ { "void*" "ReleasePrimitiveArrayCritical" }
+ { "void*" "GetStringCritical" }
+ { "void*" "ReleaseStringCritical" }
+ { "void*" "NewWeakGlobalRef" }
+ { "void*" "DeleteWeakGlobalRef" }
+ { "void*" "ExceptionCheck" }
+ { "void*" "NewDirectByteBuffer" }
+ { "void*" "GetDirectBufferAddress" }
+ { "void*" "GetDirectBufferCapacity" } ;
+
+C-STRUCT: JNIEnv
+ { "JNINativeInterface*" "functions" } ;
+
+FUNCTION: jint JNI_GetDefaultJavaVMInitArgs ( jdk-init-args* args ) ;
+FUNCTION: jint JNI_CreateJavaVM ( void** pvm, void** penv, void* args ) ;
+
+: <jdk-init-args> ( -- jdk-init-args )
+ "jdk-init-args" <c-object> HEX: 00010004 over set-jdk-init-args-version ;
+
+: jni1 ( -- init-args int )
+ <jdk-init-args> dup JNI_GetDefaultJavaVMInitArgs ;
+
+: jni2 ( -- vm env int )
+ f <void*> f <void*> [
+ jni1 drop JNI_CreateJavaVM
+ ] 2keep rot dup 0 = [
+ >r >r 0 swap void*-nth r> 0 swap void*-nth r>
+ ] when ;
+
+: (destroy-java-vm)
+ "int" { "void*" } "cdecl" alien-indirect ;
+
+: (attach-current-thread)
+ "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ;
+
+: (detach-current-thread)
+ "int" { "void*" } "cdecl" alien-indirect ;
+
+: (get-env)
+ "int" { "void*" "void*" "int" } "cdecl" alien-indirect ;
+
+: (attach-current-thread-as-daemon)
+ "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ;
+
+: destroy-java-vm ( javavm -- int )
+ dup JavaVM-functions JNIInvokeInterface-DestroyJavaVM (destroy-java-vm) ;
+
+: (get-version)
+ "jint" { "JNIEnv*" } "cdecl" alien-indirect ;
+
+: get-version ( jnienv -- int )
+ dup JNIEnv-functions JNINativeInterface-GetVersion (get-version) ;
+
+: (find-class)
+ "void*" { "JNINativeInterface*" "char*" } "cdecl" alien-indirect ;
+
+: find-class ( name jnienv -- int )
+ dup swapd JNIEnv-functions JNINativeInterface-FindClass (find-class) ;
+
+: (get-static-field-id)
+ "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ;
+
+: get-static-field-id ( class name sig jnienv -- int )
+ dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetStaticFieldID (get-static-field-id) ;
+
+: (get-static-object-field)
+ "void*" { "JNINativeInterface*" "void*" "void*" } "cdecl" alien-indirect ;
+
+: get-static-object-field ( class id jnienv -- int )
+ dup >r >r 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-GetStaticObjectField (get-static-object-field) ;
+
+: (get-method-id)
+ "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ;
+
+: get-method-id ( class name sig jnienv -- int )
+ dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetMethodID (get-method-id) ;
+
+: (new-string)
+ "void*" { "JNINativeInterface*" "char*" "int" } "cdecl" alien-indirect ;
+
+: new-string ( str jnienv -- str )
+ dup >r >r dup length 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-NewString (new-string) ;
+
+: (call1)
+ "void" { "JNINativeInterface*" "void*" "void*" "int" } "cdecl" alien-indirect ;
+
+: call1 ( obj method-id jstr jnienv -- )
+ dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-CallObjectMethod (call1) ;
+
diff --git a/unmaintained/jni/jni.factor b/unmaintained/jni/jni.factor
new file mode 100644
index 0000000000..86e1670c50
--- /dev/null
+++ b/unmaintained/jni/jni.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+IN: jni
+USING: kernel jni-internals namespaces ;
+
+! High level interface for JNI to be added here...
+
+: test0 ( -- )
+ jni2 drop nip "env" set ;
+
+: test1 ( -- system )
+ "java/lang/System" "env" get find-class ;
+
+: test2 ( system -- system.out )
+ dup "out" "Ljava/io/PrintStream;" "env" get get-static-field-id
+ "env" get get-static-object-field ;
+
+: test3 ( int system.out -- )
+ "java/io/PrintStream" "env" get find-class ! jstr out class
+ "println" "(I)V" "env" get get-method-id ! jstr out id
+ rot "env" get call1 ;
+
\ No newline at end of file
diff --git a/unmaintained/jni/load.factor b/unmaintained/jni/load.factor
new file mode 100644
index 0000000000..f5fd45c8d9
--- /dev/null
+++ b/unmaintained/jni/load.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+PROVIDE: libs/jni
+{ +files+ { "jni-internals.factor" "jni.factor" } } ;
From 1b8943a8e0476d7f68542924b3a3079dc1d2d361 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 16 Jun 2008 17:39:14 +1200
Subject: [PATCH 02/85] Add failing peg.ebnf tests
---
extra/peg/ebnf/ebnf-tests.factor | 33 ++++++++++++++++++++++++++++++++
1 file changed, 33 insertions(+)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index faaa63f4bd..425c05f391 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -365,3 +365,36 @@ main = Primary
"ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
] unit-test
+{ V{ "a" "a" "a" } } [
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ drop x ]] EBNF] call ast>>
+] unit-test
+
+{ t } [
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ drop x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ drop x ]] EBNF] call ast>> =
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+ "aaa" [EBNF a=('a')* b=a:x => [[ drop x ]] EBNF] call ast>>
+] unit-test
+
+{ t } [
+ "aaa" [EBNF a=('a')* b=a:x => [[ drop x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=(a):x => [[ drop x ]] EBNF] call ast>> =
+] unit-test
+
+{ t } [
+ "number=(digit)+:n 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=(digit)+ 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=digit+ 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=digit+:n 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
\ No newline at end of file
From f1219c906aab7aa0d84b27694e998f2960c30775 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 15:25:47 +1200
Subject: [PATCH 03/85] Check stack effect of actions in ebnf. Do implicit drop
if needed
---
extra/peg/ebnf/ebnf.factor | 13 ++++++++++---
1 file changed, 10 insertions(+), 3 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index fc10a65024..44765cc60c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
- peg.parsers unicode.categories multiline combinators.lib
- splitting accessors effects sequences.deep peg.search ;
+ peg.parsers unicode.categories multiline combinators combinators.lib
+ splitting accessors effects sequences.deep peg.search inference ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -340,9 +340,16 @@ M: ebnf-var build-locals ( code ast -- )
M: object build-locals ( code ast -- )
drop ;
+: check-action-effect ( quot -- quot )
+ dup infer {
+ { [ dup (( a -- b )) effect<= ] [ drop ] }
+ { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
+ [ "Bad effect: " swap effect>string append throw ]
+ } cond ;
+
M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
- string-lines parse-lines action ;
+ string-lines parse-lines check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
From dfa4926a84f5fbec165fe398fe7ed78e3666f298 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 22:47:38 +1200
Subject: [PATCH 04/85] Print ebnf quotation on error. Fix generated local
quotation
---
extra/peg/ebnf/ebnf.factor | 14 ++++++++++----
1 file changed, 10 insertions(+), 4 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 44765cc60c..335607b463 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,8 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators combinators.lib
- splitting accessors effects sequences.deep peg.search inference ;
+ splitting accessors effects sequences.deep peg.search inference
+ io.streams.string io prettyprint ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -324,7 +325,7 @@ M: ebnf-sequence build-locals ( code ast -- code )
] 2each
" | " %
%
- " ]" %
+ " nip ]" %
] "" make
] if ;
@@ -334,7 +335,7 @@ M: ebnf-var build-locals ( code ast -- )
name>> % " [ dup ] " %
" | " %
%
- " ]" %
+ " nip ]" %
] "" make ;
M: object build-locals ( code ast -- )
@@ -344,7 +345,12 @@ M: object build-locals ( code ast -- )
dup infer {
{ [ dup (( a -- b )) effect<= ] [ drop ] }
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
- [ "Bad effect: " swap effect>string append throw ]
+ [
+ [
+ "Bad effect: " write effect>string write
+ " for quotation " write pprint
+ ] with-string-writer throw
+ ]
} cond ;
M: ebnf-action (transform) ( ast -- parser )
From 479fa6a5b5a3ea5ebec18d4eba8ae30579531c60 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 15:07:23 +1200
Subject: [PATCH 05/85] Add support for calling foreign peg.ebnf rules
---
extra/peg/ebnf/ebnf.factor | 43 +++++++++++++++++++++++++++++++++-----
1 file changed, 38 insertions(+), 5 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 335607b463..4828ace9af 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -1,14 +1,19 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.units parser words arrays strings math.parser sequences
+USING: kernel compiler.units words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators combinators.lib
splitting accessors effects sequences.deep peg.search inference
- io.streams.string io prettyprint ;
+ io.streams.string io prettyprint parser ;
IN: peg.ebnf
+: rule ( name word -- parser )
+ #! Given an EBNF word produced from EBNF: return the EBNF rule
+ "ebnf-parser" word-prop at ;
+
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
+TUPLE: ebnf-foreign word rule ;
TUPLE: ebnf-any-character ;
TUPLE: ebnf-range pattern ;
TUPLE: ebnf-ensure group ;
@@ -27,6 +32,7 @@ TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
+C: <ebnf-foreign> ebnf-foreign
C: <ebnf-any-character> ebnf-any-character
C: <ebnf-range> ebnf-range
C: <ebnf-ensure> ebnf-ensure
@@ -88,6 +94,8 @@ C: <ebnf> ebnf
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
+ [ dup CHAR: < = ]
+ [ dup CHAR: > = ]
} 0|| not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
@@ -96,6 +104,24 @@ C: <ebnf> ebnf
#! and it represents the literal value of the identifier.
'identifier' [ <ebnf-terminal> ] action ;
+: 'foreign-name' ( -- parser )
+ #! Parse a valid foreign parser name
+ [
+ {
+ [ dup blank? ]
+ [ dup CHAR: > = ]
+ } 0|| not nip
+ ] satisfy repeat1 [ >string ] action ;
+
+: 'foreign' ( -- parser )
+ #! A foreign call is a call to a rule in another ebnf grammar
+ [
+ "<foreign" syntax ,
+ 'foreign-name' sp ,
+ 'foreign-name' sp optional ,
+ ">" syntax ,
+ ] seq* [ first2 <ebnf-foreign> ] action ;
+
: 'any-character' ( -- parser )
#! A parser to match the symbol for any character match.
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
@@ -117,6 +143,7 @@ C: <ebnf> ebnf
[
'non-terminal' ,
'terminal' ,
+ 'foreign' ,
'range-parser' ,
'any-character' ,
] choice* ,
@@ -367,6 +394,15 @@ M: ebnf-var (transform) ( ast -- parser )
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token ;
+M: ebnf-foreign (transform) ( ast -- parser )
+ dup word>> search
+ [ "Foreign word " swap word>> append " not found" append throw ] unless*
+ swap rule>> dup [
+ swap rule
+ ] [
+ execute
+ ] if ;
+
: parser-not-found ( name -- * )
[
"Parser " % % " not found." %
@@ -411,6 +447,3 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
";EBNF" parse-multiline-string replace-escapes
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
-: rule ( name word -- parser )
- #! Given an EBNF word produced from EBNF: return the EBNF rule
- "ebnf-parser" word-prop at ;
\ No newline at end of file
From 0841dbb4ad4567652a0acc53d3a0e1d4b24b4855 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 15:21:10 +1200
Subject: [PATCH 06/85] Fix ebnf unit test
---
extra/peg/ebnf/ebnf-tests.factor | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 425c05f391..04cc01c9d0 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -164,23 +164,23 @@ IN: peg.ebnf.tests
] unit-test
{ 6 } [
- "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call ast>>
+ "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] call ast>>
] unit-test
{ 6 } [
- "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call ast>>
+ "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] call ast>>
] unit-test
{ 10 } [
- { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
+ { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
- { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
+ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call
] unit-test
{ 3 } [
- { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
+ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
@@ -251,7 +251,7 @@ IN: peg.ebnf.tests
] unit-test
{ t } [
- "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty?
+ "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' parse parse-result-remaining empty?
] unit-test
EBNF: primary
@@ -366,21 +366,21 @@ main = Primary
] unit-test
{ V{ "a" "a" "a" } } [
- "aaa" [EBNF a=('a')* b=!('b') a:x => [[ drop x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
] unit-test
{ t } [
- "aaa" [EBNF a=('a')* b=!('b') a:x => [[ drop x ]] EBNF] call ast>>
- "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ drop x ]] EBNF] call ast>> =
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] call ast>> =
] unit-test
{ V{ "a" "a" "a" } } [
- "aaa" [EBNF a=('a')* b=a:x => [[ drop x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
] unit-test
{ t } [
- "aaa" [EBNF a=('a')* b=a:x => [[ drop x ]] EBNF] call ast>>
- "aaa" [EBNF a=('a')* b=(a):x => [[ drop x ]] EBNF] call ast>> =
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] call ast>> =
] unit-test
{ t } [
From f4f4ea7eb6fd5b78f635ecbc019649db1a1dd817 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 17:34:21 +1200
Subject: [PATCH 07/85] Fix peg.ebnf unit test failures
---
extra/peg/ebnf/ebnf.factor | 68 ++++++++++++++++++++++++--------------
1 file changed, 43 insertions(+), 25 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4828ace9af..215eabdd37 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -49,6 +49,10 @@ C: <ebnf-var> ebnf-var
C: <ebnf-semantic> ebnf-semantic
C: <ebnf> ebnf
+: filter-hidden ( seq -- seq )
+ #! Remove elements that produce no AST from sequence
+ [ ebnf-ensure-not? not ] filter [ ebnf-ensure? not ] filter ;
+
: syntax ( string -- parser )
#! Parses the string, ignoring white space, and
#! does not put the result in the AST.
@@ -140,12 +144,18 @@ C: <ebnf> ebnf
#! The latter indicates that it is the beginning of a
#! new rule.
[
- [
- 'non-terminal' ,
- 'terminal' ,
- 'foreign' ,
- 'range-parser' ,
- 'any-character' ,
+ [
+ [
+ 'non-terminal' ,
+ 'terminal' ,
+ 'foreign' ,
+ 'range-parser' ,
+ 'any-character' ,
+ ] choice*
+ [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,
+ [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,
+ [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,
+ ,
] choice* ,
[
"=" syntax ensure-not ,
@@ -153,6 +163,8 @@ C: <ebnf> ebnf
] choice* ,
] seq* [ first ] action ;
+DEFER: 'action'
+
: 'element' ( -- parser )
[
[ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
@@ -256,7 +268,7 @@ DEFER: 'choice'
] choice* ;
: 'choice' ( -- parser )
- 'actioned-sequence' sp "|" token sp list-of [
+ 'actioned-sequence' sp repeat1 [ dup length 1 = [ first ] [ <ebnf-sequence> ] if ] action "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
@@ -337,23 +349,29 @@ M: ebnf-whitespace (transform) ( ast -- parser )
GENERIC: build-locals ( code ast -- code )
M: ebnf-sequence build-locals ( code ast -- code )
- elements>> dup [ ebnf-var? ] filter empty? [
- drop
- ] [
- [
- "USING: locals sequences ; [let* | " %
- dup length swap [
- dup ebnf-var? [
- name>> %
- " [ " % # " over nth ] " %
- ] [
- 2drop
- ] if
- ] 2each
- " | " %
- %
- " nip ]" %
- ] "" make
+ #! Note the need to filter out this ebnf items that
+ #! leave nothing in the AST
+ elements>> filter-hidden dup length 1 = [
+ first build-locals
+ ] [
+ dup [ ebnf-var? ] filter empty? [
+ drop
+ ] [
+ [
+ "USING: locals sequences ; [let* | " %
+ dup length swap [
+ dup ebnf-var? [
+ name>> %
+ " [ " % # " over nth ] " %
+ ] [
+ 2drop
+ ] if
+ ] 2each
+ " | " %
+ %
+ " nip ]" %
+ ] "" make
+ ] if
] if ;
M: ebnf-var build-locals ( code ast -- )
@@ -381,7 +399,7 @@ M: object build-locals ( code ast -- )
} cond ;
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
string-lines parse-lines check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
From b338fc8feaa04050cac2e10be76a4d7cf812c4b3 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 21:55:53 +1200
Subject: [PATCH 08/85] Javascript parser
---
extra/peg/javascript/javascript.factor | 247 +++++++++++++++++++++++++
1 file changed, 247 insertions(+)
create mode 100644 extra/peg/javascript/javascript.factor
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
new file mode 100644
index 0000000000..33fd6dd069
--- /dev/null
+++ b/extra/peg/javascript/javascript.factor
@@ -0,0 +1,247 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays strings math.parser sequences sequences.deep
+peg peg.ebnf peg.parsers memoize namespaces math ;
+IN: peg.javascript
+
+#! Grammar for JavaScript. Based on OMeta-JS example from:
+#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+
+USE: prettyprint
+
+TUPLE: ast-keyword value ;
+TUPLE: ast-name value ;
+TUPLE: ast-number value ;
+TUPLE: ast-string value ;
+TUPLE: ast-cond-expr condition then else ;
+TUPLE: ast-set lhs rhs ;
+TUPLE: ast-get value ;
+TUPLE: ast-mset lhs rhs operator ;
+TUPLE: ast-binop lhs rhs operator ;
+TUPLE: ast-unop expr operator ;
+TUPLE: ast-postop expr operator ;
+TUPLE: ast-preop expr operator ;
+TUPLE: ast-getp index expr ;
+TUPLE: ast-send method expr args ;
+TUPLE: ast-call expr args ;
+TUPLE: ast-this ;
+TUPLE: ast-new name args ;
+TUPLE: ast-array values ;
+TUPLE: ast-json bindings ;
+TUPLE: ast-binding name value ;
+TUPLE: ast-func fs body ;
+TUPLE: ast-var name value ;
+TUPLE: ast-begin statements ;
+TUPLE: ast-if condition true false ;
+TUPLE: ast-while condition statements ;
+TUPLE: ast-do-while statements condition ;
+TUPLE: ast-for i c u statements ;
+TUPLE: ast-for-in v e statements ;
+TUPLE: ast-switch expr statements ;
+TUPLE: ast-break ;
+TUPLE: ast-continue ;
+TUPLE: ast-throw e ;
+TUPLE: ast-try t e c f ;
+TUPLE: ast-return e ;
+TUPLE: ast-case c cs ;
+TUPLE: ast-default cs ;
+C: <ast-name> ast-name
+C: <ast-keyword> ast-keyword
+C: <ast-number> ast-number
+C: <ast-string> ast-string
+C: <ast-cond-expr> ast-cond-expr
+C: <ast-set> ast-set
+C: <ast-get> ast-get
+C: <ast-mset> ast-mset
+C: <ast-binop> ast-binop
+C: <ast-unop> ast-unop
+C: <ast-preop> ast-preop
+C: <ast-postop> ast-postop
+C: <ast-getp> ast-getp
+C: <ast-send> ast-send
+C: <ast-call> ast-call
+C: <ast-this> ast-this
+C: <ast-new> ast-new
+C: <ast-array> ast-array
+C: <ast-json> ast-json
+C: <ast-binding> ast-binding
+C: <ast-func> ast-func
+C: <ast-var> ast-var
+C: <ast-begin> ast-begin
+C: <ast-if> ast-if
+C: <ast-while> ast-while
+C: <ast-do-while> ast-do-while
+C: <ast-for> ast-for
+C: <ast-for-in> ast-for-in
+C: <ast-switch> ast-switch
+C: <ast-break> ast-break
+C: <ast-continue> ast-continue
+C: <ast-throw> ast-throw
+C: <ast-try> ast-try
+C: <ast-return> ast-return
+C: <ast-case> ast-case
+C: <ast-default> ast-default
+
+EBNF: javascript
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = (Digit)+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ drop ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ drop ignore ]]
+Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
+Spaces = (Space)* => [[ drop ignore ]]
+NameFirst = Letter | "$" | "_"
+NameRest = NameFirst | Digit
+iName = NameFirst (NameRest)* => [[ first2 swap prefix >string ]]
+Keyword = ("break"
+ | "case"
+ | "catch"
+ | "continue"
+ | "default"
+ | "delete"
+ | "do"
+ | "else"
+ | "finally"
+ | "for"
+ | "function"
+ | "if"
+ | "in"
+ | "instanceof"
+ | "new"
+ | "return"
+ | "switch"
+ | "this"
+ | "throw"
+ | "try"
+ | "typeof"
+ | "var"
+ | "void"
+ | "while"
+ | "with") => [[ <ast-keyword> ]]
+Name = !(Keyword) (iName):n => [[ drop n <ast-name> ]]
+Number = Digits:ws '.' Digits:fs => [[ drop ws "." fs 3array concat >string string>number <ast-number> ]]
+ | Digits => [[ >string string>number <ast-number> ]]
+
+EscapeChar = "\\n" => [[ drop 10 ]]
+ | "\\r" => [[ drop 13 ]]
+ | "\\t" => [[ drop 9 ]]
+StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
+StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
+StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
+Str = '"""' StringChars1:cs '"""' => [[ drop cs <ast-string> ]]
+ | '"' StringChars2:cs '"' => [[ drop cs <ast-string> ]]
+ | "'" StringChars3:cs "'" => [[ drop cs <ast-string> ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Name | Keyword | Number | Str | Special )
+Toks = (Tok)* Spaces
+SpacesNoNl = (!("\n") Space)* => [[ drop ignore ]]
+
+Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ drop e t f <ast-cond-expr> ]]
+ | OrExpr:e "=" Expr:rhs => [[ drop e rhs <ast-set> ]]
+ | OrExpr:e "+=" Expr:rhs => [[ drop e rhs "+" <ast-mset> ]]
+ | OrExpr:e "-=" Expr:rhs => [[ drop e rhs "-" <ast-mset> ]]
+ | OrExpr:e "*=" Expr:rhs => [[ drop e rhs "*" <ast-mset> ]]
+ | OrExpr:e "/=" Expr:rhs => [[ drop e rhs "/" <ast-mset> ]]
+ | OrExpr:e "%=" Expr:rhs => [[ drop e rhs "%" <ast-mset> ]]
+ | OrExpr:e "&&=" Expr:rhs => [[ drop e rhs "&&" <ast-mset> ]]
+ | OrExpr:e "||=" Expr:rhs => [[ drop e rhs "||" <ast-mset> ]]
+ | OrExpr:e => [[ drop e ]]
+
+OrExpr = OrExpr:x "||" AndExpr:y => [[ drop x y "||" <ast-binop> ]]
+ | AndExpr
+AndExpr = AndExpr:x "&&" EqExpr:y => [[ drop x y "&&" <ast-binop> ]]
+ | EqExpr
+EqExpr = EqExpr:x "==" RelExpr:y => [[ drop x y "==" <ast-binop> ]]
+ | EqExpr:x "!=" RelExpr:y => [[ drop x y "!=" <ast-binop> ]]
+ | EqExpr:x "===" RelExpr:y => [[ drop x y "===" <ast-binop> ]]
+ | EqExpr:x "!==" RelExpr:y => [[ drop x y "!==" <ast-binop> ]]
+ | RelExpr
+RelExpr = RelExpr:x ">" AddExpr:y => [[ drop x y ">" <ast-binop> ]]
+ | RelExpr:x ">=" AddExpr:y => [[ drop x y ">=" <ast-binop> ]]
+ | RelExpr:x "<" AddExpr:y => [[ drop x y "<" <ast-binop> ]]
+ | RelExpr:x "<=" AddExpr:y => [[ drop x y "<=" <ast-binop> ]]
+ | RelExpr:x "instanceof" AddExpr:y => [[ drop x y "instanceof" <ast-binop> ]]
+ | AddExpr
+AddExpr = AddExpr:x "+" MulExpr:y => [[ drop x y "+" <ast-binop> ]]
+ | AddExpr:x "-" MulExpr:y => [[ drop x y "-" <ast-binop> ]]
+ | MulExpr
+MulExpr = MulExpr:x "*" MulExpr:y => [[ drop x y "*" <ast-binop> ]]
+ | MulExpr:x "/" MulExpr:y => [[ drop x y "/" <ast-binop> ]]
+ | MulExpr:x "%" MulExpr:y => [[ drop x y "%" <ast-binop> ]]
+ | Unary
+Unary = "-" Postfix:p => [[ drop p "-" <ast-unop> ]]
+ | "+" Postfix:p => [[ drop p ]]
+ | "++" Postfix:p => [[ drop p "++" <ast-preop> ]]
+ | "--" Postfix:p => [[ drop p "--" <ast-preop> ]]
+ | "!" Postfix:p => [[ drop p "!" <ast-unop> ]]
+ | Postfix
+Postfix = PrimExpr:p SpacesNoNl "++" => [[ drop p "++" <ast-postop> ]]
+ | PrimExpr:p SpacesNoNl "--" => [[ drop p "--" <ast-postop> ]]
+ | PrimExpr
+Args = Expr ("," Expr)* => [[ first2 swap prefix ]]
+PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ drop i p <ast-getp> ]]
+ | PrimExpr:p "." Name:m "(" Args:as ")" => [[ drop m p as <ast-send> ]]
+ | PrimExpr:p "." Name:f => [[ drop f p <ast-getp> ]]
+ | PrimExpr:p "(" Args:as ")" => [[ drop p as <ast-call> ]]
+ | PrimExprHd
+PrimExprHd = "(" Expr:e ")" => [[ drop e ]]
+ | "this" => [[ drop <ast-this> ]]
+ | Name => [[ <ast-get> ]]
+ | Number => [[ <ast-number> ]]
+ | Str => [[ <ast-string> ]]
+ | "function" FuncRest:fr => [[ drop fr ]]
+ | "new" Name:n "(" Args:as ")" => [[ drop n as <ast-new> ]]
+ | "[" Args:es "]" => [[ drop es <ast-array> ]]
+ | Json
+JsonBindings = JsonBinding ("," JsonBinding)* => [[ first2 swap prefix ]]
+Json = "{" JsonBindings:bs "}" => [[ drop bs <ast-json> ]]
+JsonBinding = JsonPropName:n ":" Expr:v => [[ drop n v <ast-binding> ]]
+JsonPropName = Name | Number | Str
+Formal = Spaces Name
+Formals = Formal ("," Formal)* => [[ first2 swap prefix ]]
+FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ drop fs body <ast-func> ]]
+Sc = SpacesNoNl ("\n" | "}")| ";"
+Binding = Name:n "=" Expr:v => [[ drop n v <ast-var> ]]
+ | Name:n => [[ drop n "undefined" <ast-get> <ast-var> ]]
+Block = "{" SrcElems:ss "}" => [[ drop ss ]]
+Bindings = Binding ("," Binding)* => [[ first2 swap prefix ]]
+For1 = "var" Binding => [[ second ]]
+ | Expr
+ | Spaces => [[ "undefined" <ast-get> ]]
+For2 = Expr
+ | Spaces => [[ "true" <ast-get> ]]
+For3 = Expr
+ | Spaces => [[ "undefined" <ast-get> ]]
+ForIn1 = "var" Name:n => [[ drop n "undefined" <ast-get> <ast-var> ]]
+ | Expr
+Switch1 = "case" Expr:c ":" SrcElems:cs => [[ drop c cs <ast-case> ]]
+ | "default" ":" SrcElems:cs => [[ drop cs <ast-default> ]]
+SwitchBody = (Switch1)*
+Finally = "finally" Block:b => [[ drop b ]]
+ | Spaces => [[ drop "undefined" <ast-get> ]]
+Stmt = Block
+ | "var" Bindings:bs Sc => [[ drop bs <ast-begin> ]]
+ | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ drop c t f <ast-if> ]]
+ | "if" "(" Expr:c ")" Stmt:t => [[ drop c t "undefined" <ast-get> <ast-if> ]]
+ | "while" "(" Expr:c ")" Stmt:s => [[ drop c s <ast-while> ]]
+ | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ drop s c <ast-do-while> ]]
+ | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ drop i c u s <ast-for> ]]
+ | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ drop v e s <ast-for-in> ]]
+ | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ drop e cs <ast-switch> ]]
+ | "break" Sc => [[ drop <ast-break> ]]
+ | "continue" Sc => [[ drop <ast-continue> ]]
+ | "throw" SpacesNoNl Expr:e Sc => [[ drop e <ast-throw> ]]
+ | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ drop t e c f <ast-try> ]]
+ | "return" Expr:e Sc => [[ drop e <ast-return> ]]
+ | "return" Sc => [[ drop "undefined" <ast-get> <ast-return> ]]
+ | Expr:e Sc => [[ drop e ]]
+ | ";" => [[ drop "undefined" <ast-get> ]]
+SrcElem = "function" Name:n FuncRest:f => [[ drop n f <ast-var> ]]
+ | Stmt
+SrcElems = (SrcElem)* => [[ <ast-begin> ]]
+TopLevel = SrcElems Spaces
+;EBNF
\ No newline at end of file
From 79dfe2806a873b9bef9f405bb8f222eab4b86f50 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 22:07:57 +1200
Subject: [PATCH 09/85] Remove javascript boa constructors
---
extra/peg/javascript/javascript.factor | 190 ++++++++++---------------
1 file changed, 77 insertions(+), 113 deletions(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 33fd6dd069..5c76c45f4c 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -45,42 +45,6 @@ TUPLE: ast-try t e c f ;
TUPLE: ast-return e ;
TUPLE: ast-case c cs ;
TUPLE: ast-default cs ;
-C: <ast-name> ast-name
-C: <ast-keyword> ast-keyword
-C: <ast-number> ast-number
-C: <ast-string> ast-string
-C: <ast-cond-expr> ast-cond-expr
-C: <ast-set> ast-set
-C: <ast-get> ast-get
-C: <ast-mset> ast-mset
-C: <ast-binop> ast-binop
-C: <ast-unop> ast-unop
-C: <ast-preop> ast-preop
-C: <ast-postop> ast-postop
-C: <ast-getp> ast-getp
-C: <ast-send> ast-send
-C: <ast-call> ast-call
-C: <ast-this> ast-this
-C: <ast-new> ast-new
-C: <ast-array> ast-array
-C: <ast-json> ast-json
-C: <ast-binding> ast-binding
-C: <ast-func> ast-func
-C: <ast-var> ast-var
-C: <ast-begin> ast-begin
-C: <ast-if> ast-if
-C: <ast-while> ast-while
-C: <ast-do-while> ast-do-while
-C: <ast-for> ast-for
-C: <ast-for-in> ast-for-in
-C: <ast-switch> ast-switch
-C: <ast-break> ast-break
-C: <ast-continue> ast-continue
-C: <ast-throw> ast-throw
-C: <ast-try> ast-try
-C: <ast-return> ast-return
-C: <ast-case> ast-case
-C: <ast-default> ast-default
EBNF: javascript
Letter = [a-zA-Z]
@@ -117,10 +81,10 @@ Keyword = ("break"
| "var"
| "void"
| "while"
- | "with") => [[ <ast-keyword> ]]
-Name = !(Keyword) (iName):n => [[ drop n <ast-name> ]]
-Number = Digits:ws '.' Digits:fs => [[ drop ws "." fs 3array concat >string string>number <ast-number> ]]
- | Digits => [[ >string string>number <ast-number> ]]
+ | "with") => [[ ast-keyword boa ]]
+Name = !(Keyword) (iName):n => [[ drop n ast-name boa ]]
+Number = Digits:ws '.' Digits:fs => [[ drop ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
EscapeChar = "\\n" => [[ drop 10 ]]
| "\\r" => [[ drop 13 ]]
@@ -128,9 +92,9 @@ EscapeChar = "\\n" => [[ drop 10 ]]
StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
-Str = '"""' StringChars1:cs '"""' => [[ drop cs <ast-string> ]]
- | '"' StringChars2:cs '"' => [[ drop cs <ast-string> ]]
- | "'" StringChars3:cs "'" => [[ drop cs <ast-string> ]]
+Str = '"""' StringChars1:cs '"""' => [[ drop cs ast-string boa ]]
+ | '"' StringChars2:cs '"' => [[ drop cs ast-string boa ]]
+ | "'" StringChars3:cs "'" => [[ drop cs ast-string boa ]]
Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
| "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
| ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
@@ -140,108 +104,108 @@ Tok = Spaces (Name | Keyword | Number | Str | Special )
Toks = (Tok)* Spaces
SpacesNoNl = (!("\n") Space)* => [[ drop ignore ]]
-Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ drop e t f <ast-cond-expr> ]]
- | OrExpr:e "=" Expr:rhs => [[ drop e rhs <ast-set> ]]
- | OrExpr:e "+=" Expr:rhs => [[ drop e rhs "+" <ast-mset> ]]
- | OrExpr:e "-=" Expr:rhs => [[ drop e rhs "-" <ast-mset> ]]
- | OrExpr:e "*=" Expr:rhs => [[ drop e rhs "*" <ast-mset> ]]
- | OrExpr:e "/=" Expr:rhs => [[ drop e rhs "/" <ast-mset> ]]
- | OrExpr:e "%=" Expr:rhs => [[ drop e rhs "%" <ast-mset> ]]
- | OrExpr:e "&&=" Expr:rhs => [[ drop e rhs "&&" <ast-mset> ]]
- | OrExpr:e "||=" Expr:rhs => [[ drop e rhs "||" <ast-mset> ]]
+Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ drop e t f ast-cond-expr boa ]]
+ | OrExpr:e "=" Expr:rhs => [[ drop e rhs ast-set boa ]]
+ | OrExpr:e "+=" Expr:rhs => [[ drop e rhs "+" ast-mset boa ]]
+ | OrExpr:e "-=" Expr:rhs => [[ drop e rhs "-" ast-mset boa ]]
+ | OrExpr:e "*=" Expr:rhs => [[ drop e rhs "*" ast-mset boa ]]
+ | OrExpr:e "/=" Expr:rhs => [[ drop e rhs "/" ast-mset boa ]]
+ | OrExpr:e "%=" Expr:rhs => [[ drop e rhs "%" ast-mset boa ]]
+ | OrExpr:e "&&=" Expr:rhs => [[ drop e rhs "&&" ast-mset boa ]]
+ | OrExpr:e "||=" Expr:rhs => [[ drop e rhs "||" ast-mset boa ]]
| OrExpr:e => [[ drop e ]]
-OrExpr = OrExpr:x "||" AndExpr:y => [[ drop x y "||" <ast-binop> ]]
+OrExpr = OrExpr:x "||" AndExpr:y => [[ drop x y "||" ast-binop boa ]]
| AndExpr
-AndExpr = AndExpr:x "&&" EqExpr:y => [[ drop x y "&&" <ast-binop> ]]
+AndExpr = AndExpr:x "&&" EqExpr:y => [[ drop x y "&&" ast-binop boa ]]
| EqExpr
-EqExpr = EqExpr:x "==" RelExpr:y => [[ drop x y "==" <ast-binop> ]]
- | EqExpr:x "!=" RelExpr:y => [[ drop x y "!=" <ast-binop> ]]
- | EqExpr:x "===" RelExpr:y => [[ drop x y "===" <ast-binop> ]]
- | EqExpr:x "!==" RelExpr:y => [[ drop x y "!==" <ast-binop> ]]
+EqExpr = EqExpr:x "==" RelExpr:y => [[ drop x y "==" ast-binop boa ]]
+ | EqExpr:x "!=" RelExpr:y => [[ drop x y "!=" ast-binop boa ]]
+ | EqExpr:x "===" RelExpr:y => [[ drop x y "===" ast-binop boa ]]
+ | EqExpr:x "!==" RelExpr:y => [[ drop x y "!==" ast-binop boa ]]
| RelExpr
-RelExpr = RelExpr:x ">" AddExpr:y => [[ drop x y ">" <ast-binop> ]]
- | RelExpr:x ">=" AddExpr:y => [[ drop x y ">=" <ast-binop> ]]
- | RelExpr:x "<" AddExpr:y => [[ drop x y "<" <ast-binop> ]]
- | RelExpr:x "<=" AddExpr:y => [[ drop x y "<=" <ast-binop> ]]
- | RelExpr:x "instanceof" AddExpr:y => [[ drop x y "instanceof" <ast-binop> ]]
+RelExpr = RelExpr:x ">" AddExpr:y => [[ drop x y ">" ast-binop boa ]]
+ | RelExpr:x ">=" AddExpr:y => [[ drop x y ">=" ast-binop boa ]]
+ | RelExpr:x "<" AddExpr:y => [[ drop x y "<" ast-binop boa ]]
+ | RelExpr:x "<=" AddExpr:y => [[ drop x y "<=" ast-binop boa ]]
+ | RelExpr:x "instanceof" AddExpr:y => [[ drop x y "instanceof" ast-binop boa ]]
| AddExpr
-AddExpr = AddExpr:x "+" MulExpr:y => [[ drop x y "+" <ast-binop> ]]
- | AddExpr:x "-" MulExpr:y => [[ drop x y "-" <ast-binop> ]]
+AddExpr = AddExpr:x "+" MulExpr:y => [[ drop x y "+" ast-binop boa ]]
+ | AddExpr:x "-" MulExpr:y => [[ drop x y "-" ast-binop boa ]]
| MulExpr
-MulExpr = MulExpr:x "*" MulExpr:y => [[ drop x y "*" <ast-binop> ]]
- | MulExpr:x "/" MulExpr:y => [[ drop x y "/" <ast-binop> ]]
- | MulExpr:x "%" MulExpr:y => [[ drop x y "%" <ast-binop> ]]
+MulExpr = MulExpr:x "*" MulExpr:y => [[ drop x y "*" ast-binop boa ]]
+ | MulExpr:x "/" MulExpr:y => [[ drop x y "/" ast-binop boa ]]
+ | MulExpr:x "%" MulExpr:y => [[ drop x y "%" ast-binop boa ]]
| Unary
-Unary = "-" Postfix:p => [[ drop p "-" <ast-unop> ]]
+Unary = "-" Postfix:p => [[ drop p "-" ast-unop boa ]]
| "+" Postfix:p => [[ drop p ]]
- | "++" Postfix:p => [[ drop p "++" <ast-preop> ]]
- | "--" Postfix:p => [[ drop p "--" <ast-preop> ]]
- | "!" Postfix:p => [[ drop p "!" <ast-unop> ]]
+ | "++" Postfix:p => [[ drop p "++" ast-preop boa ]]
+ | "--" Postfix:p => [[ drop p "--" ast-preop boa ]]
+ | "!" Postfix:p => [[ drop p "!" ast-unop boa ]]
| Postfix
-Postfix = PrimExpr:p SpacesNoNl "++" => [[ drop p "++" <ast-postop> ]]
- | PrimExpr:p SpacesNoNl "--" => [[ drop p "--" <ast-postop> ]]
+Postfix = PrimExpr:p SpacesNoNl "++" => [[ drop p "++" ast-postop boa ]]
+ | PrimExpr:p SpacesNoNl "--" => [[ drop p "--" ast-postop boa ]]
| PrimExpr
Args = Expr ("," Expr)* => [[ first2 swap prefix ]]
-PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ drop i p <ast-getp> ]]
- | PrimExpr:p "." Name:m "(" Args:as ")" => [[ drop m p as <ast-send> ]]
- | PrimExpr:p "." Name:f => [[ drop f p <ast-getp> ]]
- | PrimExpr:p "(" Args:as ")" => [[ drop p as <ast-call> ]]
+PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ drop i p ast-getp boa ]]
+ | PrimExpr:p "." Name:m "(" Args:as ")" => [[ drop m p as ast-send boa ]]
+ | PrimExpr:p "." Name:f => [[ drop f p ast-getp boa ]]
+ | PrimExpr:p "(" Args:as ")" => [[ drop p as ast-call boa ]]
| PrimExprHd
PrimExprHd = "(" Expr:e ")" => [[ drop e ]]
- | "this" => [[ drop <ast-this> ]]
- | Name => [[ <ast-get> ]]
- | Number => [[ <ast-number> ]]
- | Str => [[ <ast-string> ]]
+ | "this" => [[ drop ast-this boa ]]
+ | Name => [[ ast-get boa ]]
+ | Number => [[ ast-number boa ]]
+ | Str => [[ ast-string boa ]]
| "function" FuncRest:fr => [[ drop fr ]]
- | "new" Name:n "(" Args:as ")" => [[ drop n as <ast-new> ]]
- | "[" Args:es "]" => [[ drop es <ast-array> ]]
+ | "new" Name:n "(" Args:as ")" => [[ drop n as ast-new boa ]]
+ | "[" Args:es "]" => [[ drop es ast-array boa ]]
| Json
JsonBindings = JsonBinding ("," JsonBinding)* => [[ first2 swap prefix ]]
-Json = "{" JsonBindings:bs "}" => [[ drop bs <ast-json> ]]
-JsonBinding = JsonPropName:n ":" Expr:v => [[ drop n v <ast-binding> ]]
+Json = "{" JsonBindings:bs "}" => [[ drop bs ast-json boa ]]
+JsonBinding = JsonPropName:n ":" Expr:v => [[ drop n v ast-binding boa ]]
JsonPropName = Name | Number | Str
Formal = Spaces Name
Formals = Formal ("," Formal)* => [[ first2 swap prefix ]]
-FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ drop fs body <ast-func> ]]
+FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ drop fs body ast-func boa ]]
Sc = SpacesNoNl ("\n" | "}")| ";"
-Binding = Name:n "=" Expr:v => [[ drop n v <ast-var> ]]
- | Name:n => [[ drop n "undefined" <ast-get> <ast-var> ]]
+Binding = Name:n "=" Expr:v => [[ drop n v ast-var boa ]]
+ | Name:n => [[ drop n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ drop ss ]]
Bindings = Binding ("," Binding)* => [[ first2 swap prefix ]]
For1 = "var" Binding => [[ second ]]
| Expr
- | Spaces => [[ "undefined" <ast-get> ]]
+ | Spaces => [[ "undefined" ast-get boa ]]
For2 = Expr
- | Spaces => [[ "true" <ast-get> ]]
+ | Spaces => [[ "true" ast-get boa ]]
For3 = Expr
- | Spaces => [[ "undefined" <ast-get> ]]
-ForIn1 = "var" Name:n => [[ drop n "undefined" <ast-get> <ast-var> ]]
+ | Spaces => [[ "undefined" ast-get boa ]]
+ForIn1 = "var" Name:n => [[ drop n "undefined" ast-get boa ast-var boa ]]
| Expr
-Switch1 = "case" Expr:c ":" SrcElems:cs => [[ drop c cs <ast-case> ]]
- | "default" ":" SrcElems:cs => [[ drop cs <ast-default> ]]
+Switch1 = "case" Expr:c ":" SrcElems:cs => [[ drop c cs ast-case boa ]]
+ | "default" ":" SrcElems:cs => [[ drop cs ast-default boa ]]
SwitchBody = (Switch1)*
Finally = "finally" Block:b => [[ drop b ]]
- | Spaces => [[ drop "undefined" <ast-get> ]]
+ | Spaces => [[ drop "undefined" ast-get boa ]]
Stmt = Block
- | "var" Bindings:bs Sc => [[ drop bs <ast-begin> ]]
- | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ drop c t f <ast-if> ]]
- | "if" "(" Expr:c ")" Stmt:t => [[ drop c t "undefined" <ast-get> <ast-if> ]]
- | "while" "(" Expr:c ")" Stmt:s => [[ drop c s <ast-while> ]]
- | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ drop s c <ast-do-while> ]]
- | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ drop i c u s <ast-for> ]]
- | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ drop v e s <ast-for-in> ]]
- | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ drop e cs <ast-switch> ]]
- | "break" Sc => [[ drop <ast-break> ]]
- | "continue" Sc => [[ drop <ast-continue> ]]
- | "throw" SpacesNoNl Expr:e Sc => [[ drop e <ast-throw> ]]
- | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ drop t e c f <ast-try> ]]
- | "return" Expr:e Sc => [[ drop e <ast-return> ]]
- | "return" Sc => [[ drop "undefined" <ast-get> <ast-return> ]]
+ | "var" Bindings:bs Sc => [[ drop bs ast-begin boa ]]
+ | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ drop c t f ast-if boa ]]
+ | "if" "(" Expr:c ")" Stmt:t => [[ drop c t "undefined" ast-get boa ast-if boa ]]
+ | "while" "(" Expr:c ")" Stmt:s => [[ drop c s ast-while boa ]]
+ | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ drop s c ast-do-while boa ]]
+ | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ drop i c u s ast-for boa ]]
+ | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ drop v e s ast-for-in boa ]]
+ | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ drop e cs ast-switch boa ]]
+ | "break" Sc => [[ drop ast-break boa ]]
+ | "continue" Sc => [[ drop ast-continue boa ]]
+ | "throw" SpacesNoNl Expr:e Sc => [[ drop e ast-throw boa ]]
+ | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ drop t e c f ast-try boa ]]
+ | "return" Expr:e Sc => [[ drop e ast-return boa ]]
+ | "return" Sc => [[ drop "undefined" ast-get boa ast-return boa ]]
| Expr:e Sc => [[ drop e ]]
- | ";" => [[ drop "undefined" <ast-get> ]]
-SrcElem = "function" Name:n FuncRest:f => [[ drop n f <ast-var> ]]
+ | ";" => [[ drop "undefined" ast-get boa ]]
+SrcElem = "function" Name:n FuncRest:f => [[ drop n f ast-var boa ]]
| Stmt
-SrcElems = (SrcElem)* => [[ <ast-begin> ]]
+SrcElems = (SrcElem)* => [[ ast-begin boa ]]
TopLevel = SrcElems Spaces
;EBNF
\ No newline at end of file
From 55216a990dc5eaf37dee3345426454876994e70a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 22:47:05 +1200
Subject: [PATCH 10/85] Remove drop from actions
---
extra/peg/javascript/javascript.factor | 164 ++++++++++++-------------
1 file changed, 82 insertions(+), 82 deletions(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 5c76c45f4c..54b9d8aa0a 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -50,10 +50,10 @@ EBNF: javascript
Letter = [a-zA-Z]
Digit = [0-9]
Digits = (Digit)+
-SingleLineComment = "//" (!("\n") .)* "\n" => [[ drop ignore ]]
-MultiLineComment = "/*" (!("*/") .)* "*/" => [[ drop ignore ]]
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
-Spaces = (Space)* => [[ drop ignore ]]
+Spaces = (Space)* => [[ ignore ]]
NameFirst = Letter | "$" | "_"
NameRest = NameFirst | Digit
iName = NameFirst (NameRest)* => [[ first2 swap prefix >string ]]
@@ -82,19 +82,19 @@ Keyword = ("break"
| "void"
| "while"
| "with") => [[ ast-keyword boa ]]
-Name = !(Keyword) (iName):n => [[ drop n ast-name boa ]]
-Number = Digits:ws '.' Digits:fs => [[ drop ws "." fs 3array concat >string string>number ast-number boa ]]
+Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
-EscapeChar = "\\n" => [[ drop 10 ]]
- | "\\r" => [[ drop 13 ]]
- | "\\t" => [[ drop 9 ]]
+EscapeChar = "\\n" => [[ 10 ]]
+ | "\\r" => [[ 13 ]]
+ | "\\t" => [[ 9 ]]
StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
-Str = '"""' StringChars1:cs '"""' => [[ drop cs ast-string boa ]]
- | '"' StringChars2:cs '"' => [[ drop cs ast-string boa ]]
- | "'" StringChars3:cs "'" => [[ drop cs ast-string boa ]]
+Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
+ | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
+ | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
| "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
| ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
@@ -102,76 +102,76 @@ Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | "
| "&&" | "||=" | "||" | "." | "!"
Tok = Spaces (Name | Keyword | Number | Str | Special )
Toks = (Tok)* Spaces
-SpacesNoNl = (!("\n") Space)* => [[ drop ignore ]]
+SpacesNoNl = (!("\n") Space)* => [[ ignore ]]
-Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ drop e t f ast-cond-expr boa ]]
- | OrExpr:e "=" Expr:rhs => [[ drop e rhs ast-set boa ]]
- | OrExpr:e "+=" Expr:rhs => [[ drop e rhs "+" ast-mset boa ]]
- | OrExpr:e "-=" Expr:rhs => [[ drop e rhs "-" ast-mset boa ]]
- | OrExpr:e "*=" Expr:rhs => [[ drop e rhs "*" ast-mset boa ]]
- | OrExpr:e "/=" Expr:rhs => [[ drop e rhs "/" ast-mset boa ]]
- | OrExpr:e "%=" Expr:rhs => [[ drop e rhs "%" ast-mset boa ]]
- | OrExpr:e "&&=" Expr:rhs => [[ drop e rhs "&&" ast-mset boa ]]
- | OrExpr:e "||=" Expr:rhs => [[ drop e rhs "||" ast-mset boa ]]
- | OrExpr:e => [[ drop e ]]
+Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
+ | OrExpr:e "=" Expr:rhs => [[ e rhs ast-set boa ]]
+ | OrExpr:e "+=" Expr:rhs => [[ e rhs "+" ast-mset boa ]]
+ | OrExpr:e "-=" Expr:rhs => [[ e rhs "-" ast-mset boa ]]
+ | OrExpr:e "*=" Expr:rhs => [[ e rhs "*" ast-mset boa ]]
+ | OrExpr:e "/=" Expr:rhs => [[ e rhs "/" ast-mset boa ]]
+ | OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]]
+ | OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]]
+ | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]]
+ | OrExpr:e => [[ e ]]
-OrExpr = OrExpr:x "||" AndExpr:y => [[ drop x y "||" ast-binop boa ]]
+OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]]
| AndExpr
-AndExpr = AndExpr:x "&&" EqExpr:y => [[ drop x y "&&" ast-binop boa ]]
+AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]]
| EqExpr
-EqExpr = EqExpr:x "==" RelExpr:y => [[ drop x y "==" ast-binop boa ]]
- | EqExpr:x "!=" RelExpr:y => [[ drop x y "!=" ast-binop boa ]]
- | EqExpr:x "===" RelExpr:y => [[ drop x y "===" ast-binop boa ]]
- | EqExpr:x "!==" RelExpr:y => [[ drop x y "!==" ast-binop boa ]]
+EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]]
+ | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]]
+ | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]]
+ | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]]
| RelExpr
-RelExpr = RelExpr:x ">" AddExpr:y => [[ drop x y ">" ast-binop boa ]]
- | RelExpr:x ">=" AddExpr:y => [[ drop x y ">=" ast-binop boa ]]
- | RelExpr:x "<" AddExpr:y => [[ drop x y "<" ast-binop boa ]]
- | RelExpr:x "<=" AddExpr:y => [[ drop x y "<=" ast-binop boa ]]
- | RelExpr:x "instanceof" AddExpr:y => [[ drop x y "instanceof" ast-binop boa ]]
+RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]]
+ | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]]
+ | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]]
+ | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]]
+ | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]]
| AddExpr
-AddExpr = AddExpr:x "+" MulExpr:y => [[ drop x y "+" ast-binop boa ]]
- | AddExpr:x "-" MulExpr:y => [[ drop x y "-" ast-binop boa ]]
+AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
+ | AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
| MulExpr
-MulExpr = MulExpr:x "*" MulExpr:y => [[ drop x y "*" ast-binop boa ]]
- | MulExpr:x "/" MulExpr:y => [[ drop x y "/" ast-binop boa ]]
- | MulExpr:x "%" MulExpr:y => [[ drop x y "%" ast-binop boa ]]
+MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
+ | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
+ | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
| Unary
-Unary = "-" Postfix:p => [[ drop p "-" ast-unop boa ]]
- | "+" Postfix:p => [[ drop p ]]
- | "++" Postfix:p => [[ drop p "++" ast-preop boa ]]
- | "--" Postfix:p => [[ drop p "--" ast-preop boa ]]
- | "!" Postfix:p => [[ drop p "!" ast-unop boa ]]
+Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
+ | "+" Postfix:p => [[ p ]]
+ | "++" Postfix:p => [[ p "++" ast-preop boa ]]
+ | "--" Postfix:p => [[ p "--" ast-preop boa ]]
+ | "!" Postfix:p => [[ p "!" ast-unop boa ]]
| Postfix
-Postfix = PrimExpr:p SpacesNoNl "++" => [[ drop p "++" ast-postop boa ]]
- | PrimExpr:p SpacesNoNl "--" => [[ drop p "--" ast-postop boa ]]
+Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
+ | PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
| PrimExpr
Args = Expr ("," Expr)* => [[ first2 swap prefix ]]
-PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ drop i p ast-getp boa ]]
- | PrimExpr:p "." Name:m "(" Args:as ")" => [[ drop m p as ast-send boa ]]
- | PrimExpr:p "." Name:f => [[ drop f p ast-getp boa ]]
- | PrimExpr:p "(" Args:as ")" => [[ drop p as ast-call boa ]]
+PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
+ | PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
+ | PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
+ | PrimExpr:p "(" Args:as ")" => [[ p as ast-call boa ]]
| PrimExprHd
-PrimExprHd = "(" Expr:e ")" => [[ drop e ]]
- | "this" => [[ drop ast-this boa ]]
+PrimExprHd = "(" Expr:e ")" => [[ e ]]
+ | "this" => [[ ast-this boa ]]
| Name => [[ ast-get boa ]]
| Number => [[ ast-number boa ]]
| Str => [[ ast-string boa ]]
- | "function" FuncRest:fr => [[ drop fr ]]
- | "new" Name:n "(" Args:as ")" => [[ drop n as ast-new boa ]]
- | "[" Args:es "]" => [[ drop es ast-array boa ]]
+ | "function" FuncRest:fr => [[ fr ]]
+ | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "[" Args:es "]" => [[ es ast-array boa ]]
| Json
JsonBindings = JsonBinding ("," JsonBinding)* => [[ first2 swap prefix ]]
-Json = "{" JsonBindings:bs "}" => [[ drop bs ast-json boa ]]
-JsonBinding = JsonPropName:n ":" Expr:v => [[ drop n v ast-binding boa ]]
+Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
+JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
JsonPropName = Name | Number | Str
Formal = Spaces Name
Formals = Formal ("," Formal)* => [[ first2 swap prefix ]]
-FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ drop fs body ast-func boa ]]
+FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
Sc = SpacesNoNl ("\n" | "}")| ";"
-Binding = Name:n "=" Expr:v => [[ drop n v ast-var boa ]]
- | Name:n => [[ drop n "undefined" ast-get boa ast-var boa ]]
-Block = "{" SrcElems:ss "}" => [[ drop ss ]]
+Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
+ | Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
+Block = "{" SrcElems:ss "}" => [[ ss ]]
Bindings = Binding ("," Binding)* => [[ first2 swap prefix ]]
For1 = "var" Binding => [[ second ]]
| Expr
@@ -180,31 +180,31 @@ For2 = Expr
| Spaces => [[ "true" ast-get boa ]]
For3 = Expr
| Spaces => [[ "undefined" ast-get boa ]]
-ForIn1 = "var" Name:n => [[ drop n "undefined" ast-get boa ast-var boa ]]
+ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
| Expr
-Switch1 = "case" Expr:c ":" SrcElems:cs => [[ drop c cs ast-case boa ]]
- | "default" ":" SrcElems:cs => [[ drop cs ast-default boa ]]
+Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
+ | "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
SwitchBody = (Switch1)*
-Finally = "finally" Block:b => [[ drop b ]]
- | Spaces => [[ drop "undefined" ast-get boa ]]
+Finally = "finally" Block:b => [[ b ]]
+ | Spaces => [[ "undefined" ast-get boa ]]
Stmt = Block
- | "var" Bindings:bs Sc => [[ drop bs ast-begin boa ]]
- | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ drop c t f ast-if boa ]]
- | "if" "(" Expr:c ")" Stmt:t => [[ drop c t "undefined" ast-get boa ast-if boa ]]
- | "while" "(" Expr:c ")" Stmt:s => [[ drop c s ast-while boa ]]
- | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ drop s c ast-do-while boa ]]
- | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ drop i c u s ast-for boa ]]
- | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ drop v e s ast-for-in boa ]]
- | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ drop e cs ast-switch boa ]]
- | "break" Sc => [[ drop ast-break boa ]]
- | "continue" Sc => [[ drop ast-continue boa ]]
- | "throw" SpacesNoNl Expr:e Sc => [[ drop e ast-throw boa ]]
- | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ drop t e c f ast-try boa ]]
- | "return" Expr:e Sc => [[ drop e ast-return boa ]]
- | "return" Sc => [[ drop "undefined" ast-get boa ast-return boa ]]
- | Expr:e Sc => [[ drop e ]]
- | ";" => [[ drop "undefined" ast-get boa ]]
-SrcElem = "function" Name:n FuncRest:f => [[ drop n f ast-var boa ]]
+ | "var" Bindings:bs Sc => [[ bs ast-begin boa ]]
+ | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ c t f ast-if boa ]]
+ | "if" "(" Expr:c ")" Stmt:t => [[ c t "undefined" ast-get boa ast-if boa ]]
+ | "while" "(" Expr:c ")" Stmt:s => [[ c s ast-while boa ]]
+ | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ s c ast-do-while boa ]]
+ | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ i c u s ast-for boa ]]
+ | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ v e s ast-for-in boa ]]
+ | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ e cs ast-switch boa ]]
+ | "break" Sc => [[ ast-break boa ]]
+ | "continue" Sc => [[ ast-continue boa ]]
+ | "throw" SpacesNoNl Expr:e Sc => [[ e ast-throw boa ]]
+ | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]]
+ | "return" Expr:e Sc => [[ e ast-return boa ]]
+ | "return" Sc => [[ "undefined" ast-get boa ast-return boa ]]
+ | Expr:e Sc => [[ e ]]
+ | ";" => [[ "undefined" ast-get boa ]]
+SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
| Stmt
SrcElems = (SrcElem)* => [[ ast-begin boa ]]
TopLevel = SrcElems Spaces
From 258951d954343a8e9289425ca9c1180ba285023c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 22:59:13 +1200
Subject: [PATCH 11/85] Split out javascript tokenizer
---
extra/peg/javascript/javascript.factor | 58 ++++++++++++++++++++++++++
1 file changed, 58 insertions(+)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 54b9d8aa0a..3db962420a 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -46,6 +46,64 @@ TUPLE: ast-return e ;
TUPLE: ast-case c cs ;
TUPLE: ast-default cs ;
+EBNF: tokenizer
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = (Digit)+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
+Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
+Spaces = (Space)* => [[ ignore ]]
+NameFirst = Letter | "$" | "_"
+NameRest = NameFirst | Digit
+iName = NameFirst (NameRest)* => [[ first2 swap prefix >string ]]
+Keyword = ("break"
+ | "case"
+ | "catch"
+ | "continue"
+ | "default"
+ | "delete"
+ | "do"
+ | "else"
+ | "finally"
+ | "for"
+ | "function"
+ | "if"
+ | "in"
+ | "instanceof"
+ | "new"
+ | "return"
+ | "switch"
+ | "this"
+ | "throw"
+ | "try"
+ | "typeof"
+ | "var"
+ | "void"
+ | "while"
+ | "with") => [[ ast-keyword boa ]]
+Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
+
+EscapeChar = "\\n" => [[ 10 ]]
+ | "\\r" => [[ 13 ]]
+ | "\\t" => [[ 9 ]]
+StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
+StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
+StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
+Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
+ | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
+ | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Name | Keyword | Number | Str | Special )
+Toks = (Tok)* Spaces
+;EBNF
+
EBNF: javascript
Letter = [a-zA-Z]
Digit = [0-9]
From 4050ebcbde098f0b09a34a2123a12dbdc78d134c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 23:42:28 +1200
Subject: [PATCH 12/85] Javascript parser now works on token sequence
---
extra/peg/ebnf/ebnf.factor | 2 +-
extra/peg/javascript/javascript.factor | 66 ++++----------------------
2 files changed, 9 insertions(+), 59 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 215eabdd37..36b3742b64 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -410,7 +410,7 @@ M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
- symbol>> token ;
+ symbol>> [ token ] keep [ = ] curry satisfy 2choice ;
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 3db962420a..c9bef2f6d3 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences sequences.deep
-peg peg.ebnf peg.parsers memoize namespaces math ;
+peg peg.ebnf peg.parsers memoize namespaces math accessors ;
IN: peg.javascript
#! Grammar for JavaScript. Based on OMeta-JS example from:
@@ -81,7 +81,7 @@ Keyword = ("break"
| "var"
| "void"
| "while"
- | "with") => [[ ast-keyword boa ]]
+ | "with")
Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
@@ -105,61 +105,11 @@ Toks = (Tok)* Spaces
;EBNF
EBNF: javascript
-Letter = [a-zA-Z]
-Digit = [0-9]
-Digits = (Digit)+
-SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
-MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
-Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
+Space = " " | "\t" | "\n"
Spaces = (Space)* => [[ ignore ]]
-NameFirst = Letter | "$" | "_"
-NameRest = NameFirst | Digit
-iName = NameFirst (NameRest)* => [[ first2 swap prefix >string ]]
-Keyword = ("break"
- | "case"
- | "catch"
- | "continue"
- | "default"
- | "delete"
- | "do"
- | "else"
- | "finally"
- | "for"
- | "function"
- | "if"
- | "in"
- | "instanceof"
- | "new"
- | "return"
- | "switch"
- | "this"
- | "throw"
- | "try"
- | "typeof"
- | "var"
- | "void"
- | "while"
- | "with") => [[ ast-keyword boa ]]
-Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
-Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
- | Digits => [[ >string string>number ast-number boa ]]
-
-EscapeChar = "\\n" => [[ 10 ]]
- | "\\r" => [[ 13 ]]
- | "\\t" => [[ 9 ]]
-StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
-StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
-StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
-Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
- | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
- | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
-Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
- | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
- | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
- | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
- | "&&" | "||=" | "||" | "." | "!"
-Tok = Spaces (Name | Keyword | Number | Str | Special )
-Toks = (Tok)* Spaces
+Name = . ?[ ast-name? ]? => [[ value>> ]]
+Number = . ?[ ast-number? ]? => [[ value>> ]]
+String = . ?[ ast-string? ]? => [[ value>> ]]
SpacesNoNl = (!("\n") Space)* => [[ ignore ]]
Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
@@ -214,7 +164,7 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| "this" => [[ ast-this boa ]]
| Name => [[ ast-get boa ]]
| Number => [[ ast-number boa ]]
- | Str => [[ ast-string boa ]]
+ | String => [[ ast-string boa ]]
| "function" FuncRest:fr => [[ fr ]]
| "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
@@ -222,7 +172,7 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
JsonBindings = JsonBinding ("," JsonBinding)* => [[ first2 swap prefix ]]
Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
-JsonPropName = Name | Number | Str
+JsonPropName = Name | Number | String
Formal = Spaces Name
Formals = Formal ("," Formal)* => [[ first2 swap prefix ]]
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
From e99ff9fa6b996ba1fcf6199cfe5979bcfe221757 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 17 Jun 2008 23:57:51 +1200
Subject: [PATCH 13/85] Fix list AST in javascript parser
---
extra/peg/javascript/javascript.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index c9bef2f6d3..c4d87e3ce5 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -154,7 +154,7 @@ Unary = "-" Postfix:p => [[ p "-" ast-unop boa
Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
| PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
| PrimExpr
-Args = Expr ("," Expr)* => [[ first2 swap prefix ]]
+Args = Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]]
PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
| PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
| PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
@@ -169,18 +169,18 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
| Json
-JsonBindings = JsonBinding ("," JsonBinding)* => [[ first2 swap prefix ]]
+JsonBindings = JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]]
Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
JsonPropName = Name | Number | String
Formal = Spaces Name
-Formals = Formal ("," Formal)* => [[ first2 swap prefix ]]
+Formals = Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]]
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
Sc = SpacesNoNl ("\n" | "}")| ";"
Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
-Bindings = Binding ("," Binding)* => [[ first2 swap prefix ]]
+Bindings = Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]]
For1 = "var" Binding => [[ second ]]
| Expr
| Spaces => [[ "undefined" ast-get boa ]]
From 7694dfd68827394d5df1e61bcc0a3acba7db9e0c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 00:10:14 +1200
Subject: [PATCH 14/85] Allow zero arguments in javascript list handling
---
extra/peg/javascript/javascript.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index c4d87e3ce5..5368881377 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -154,7 +154,7 @@ Unary = "-" Postfix:p => [[ p "-" ast-unop boa
Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
| PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
| PrimExpr
-Args = Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]]
+Args = (Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]])?
PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
| PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
| PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
@@ -169,18 +169,18 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
| Json
-JsonBindings = JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]]
+JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
JsonPropName = Name | Number | String
Formal = Spaces Name
-Formals = Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]]
+Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
Sc = SpacesNoNl ("\n" | "}")| ";"
Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
-Bindings = Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]]
+Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])?
For1 = "var" Binding => [[ second ]]
| Expr
| Spaces => [[ "undefined" ast-get boa ]]
From 778573106c10aeddf03ed7384ea6270f3ea07123 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 12:16:47 +1200
Subject: [PATCH 15/85] Fix Sc rule
---
extra/peg/javascript/javascript.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 5368881377..bdf5f4b369 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -176,7 +176,7 @@ JsonPropName = Name | Number | String
Formal = Spaces Name
Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
-Sc = SpacesNoNl ("\n" | "}")| ";"
+Sc = SpacesNoNl ("\n" | &("}"))| ";"
Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
From a5719e33976ae6ebfc75ab81edd6d56dd0f0ee0a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 21:30:21 +1200
Subject: [PATCH 16/85] Add javascript tests. Minor changes to javascript
grammar
---
extra/peg/javascript/javascript-tests.factor | 42 ++++++++++++++++++++
extra/peg/javascript/javascript.factor | 16 ++++----
2 files changed, 50 insertions(+), 8 deletions(-)
create mode 100644 extra/peg/javascript/javascript-tests.factor
diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor
new file mode 100644
index 0000000000..70410a3838
--- /dev/null
+++ b/extra/peg/javascript/javascript-tests.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.javascript accessors ;
+IN: peg.javascript.tests
+
+\ javascript must-infer
+
+{
+ V{
+ T{ ast-number f 123 }
+ ";"
+ T{ ast-string f "hello" }
+ ";"
+ T{ ast-name f "foo" }
+ "("
+ T{ ast-name f "x" }
+ ")"
+ ";"
+ }
+} [
+ "123; 'hello'; foo(x);" tokenizer ast>>
+] unit-test
+
+{
+ T{
+ ast-begin
+ f
+ V{
+ T{ ast-number f 123 }
+ T{ ast-string f "hello" }
+ T{
+ ast-call
+ f
+ T{ ast-get f "foo" }
+ V{ T{ ast-get f "x" } }
+ }
+ }
+ }
+} [
+ "123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index bdf5f4b369..030d2f1728 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Chris Double.
+! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences sequences.deep
peg peg.ebnf peg.parsers memoize namespaces math accessors ;
@@ -49,14 +49,14 @@ TUPLE: ast-default cs ;
EBNF: tokenizer
Letter = [a-zA-Z]
Digit = [0-9]
-Digits = (Digit)+
+Digits = Digit+
SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
-Spaces = (Space)* => [[ ignore ]]
+Spaces = Space* => [[ ignore ]]
NameFirst = Letter | "$" | "_"
NameRest = NameFirst | Digit
-iName = NameFirst (NameRest)* => [[ first2 swap prefix >string ]]
+iName = NameFirst NameRest* => [[ first2 swap prefix >string ]]
Keyword = ("break"
| "case"
| "catch"
@@ -101,12 +101,12 @@ Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | "
| "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
| "&&" | "||=" | "||" | "." | "!"
Tok = Spaces (Name | Keyword | Number | Str | Special )
-Toks = (Tok)* Spaces
+Toks = Tok* Spaces
;EBNF
EBNF: javascript
Space = " " | "\t" | "\n"
-Spaces = (Space)* => [[ ignore ]]
+Spaces = Space* => [[ ignore ]]
Name = . ?[ ast-name? ]? => [[ value>> ]]
Number = . ?[ ast-number? ]? => [[ value>> ]]
String = . ?[ ast-string? ]? => [[ value>> ]]
@@ -192,7 +192,7 @@ ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa
| Expr
Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
| "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
-SwitchBody = (Switch1)*
+SwitchBody = Switch1*
Finally = "finally" Block:b => [[ b ]]
| Spaces => [[ "undefined" ast-get boa ]]
Stmt = Block
@@ -214,6 +214,6 @@ Stmt = Block
| ";" => [[ "undefined" ast-get boa ]]
SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
| Stmt
-SrcElems = (SrcElem)* => [[ ast-begin boa ]]
+SrcElems = SrcElem* => [[ ast-begin boa ]]
TopLevel = SrcElems Spaces
;EBNF
\ No newline at end of file
From 8f140402b3a6d94fc0e770b0c731e9ceb2f92c6c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 05:58:05 -0500
Subject: [PATCH 17/85] Move short to core
---
core/sequences/sequences.factor | 2 ++
extra/sequences/lib/lib.factor | 3 ---
2 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 02a7191f0a..2d05d3c2ef 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -206,6 +206,8 @@ M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
M: slice length dup slice-to swap slice-from - ;
+: short ( seq n -- seq n' ) over length min ; inline
+
: head-slice ( seq n -- slice ) (head) <slice> ;
: tail-slice ( seq n -- slice ) (tail) <slice> ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 56488818ab..3ac60c2ae3 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -234,9 +234,6 @@ PRIVATE>
: remove-nth ( seq n -- seq' )
cut-slice rest-slice append ;
-: short ( seq n -- seq n' )
- over length min ; inline
-
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline
From 03730f30387564b70686a85a800b25b4a089b6c3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 05:58:16 -0500
Subject: [PATCH 18/85] Fix see of M::
---
extra/locals/locals-tests.factor | 13 ++++++++++++-
extra/locals/locals.factor | 4 ++--
2 files changed, 14 insertions(+), 3 deletions(-)
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index 4e670cdac0..025e175bc2 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -1,6 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
-accessors ;
+accessors generic ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@@ -265,3 +265,14 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
[ \ a-word-with-locals see ] with-string-writer
new-definition =
] unit-test
+
+: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
+
+GENERIC: method-with-locals ( x -- y )
+
+M:: sequence method-with-locals ( a -- y ) a reverse ;
+
+[ t ] [
+ [ \ sequence \ method-with-locals method see ] with-string-writer
+ method-definition =
+] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 028502560f..cc6a7d093e 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -405,8 +405,8 @@ M: lambda-memoized reset-word
M: lambda-method synopsis*
dup dup dup definer.
- "method-specializer" word-prop pprint*
- "method-generic" word-prop pprint*
+ "method-class" word-prop pprint-word
+ "method-generic" word-prop pprint-word
method-stack-effect effect>string comment. ;
PRIVATE>
From 42f421d9884fabe528eac295aab83d532b2601fc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 05:58:26 -0500
Subject: [PATCH 19/85] Implement missing input stream protocol methods
---
.../tools/interactor/interactor-tests.factor | 46 ++++++++++++++++++-
extra/ui/tools/interactor/interactor.factor | 21 +++++++--
2 files changed, 62 insertions(+), 5 deletions(-)
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
index f8d5e33df9..37f43faa8b 100755
--- a/extra/ui/tools/interactor/interactor-tests.factor
+++ b/extra/ui/tools/interactor/interactor-tests.factor
@@ -1,7 +1,7 @@
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser accessors ;
+tools.test kernel calendar parser accessors calendar io ;
\ <interactor> must-infer
@@ -41,3 +41,47 @@ tools.test kernel calendar parser accessors ;
[ ] [ 1000 sleep ] unit-test
[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+: text "Hello world.\nThis is a test." ;
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get contents "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get stream-read1 "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 400169908b..72bd4e43a3 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -6,7 +6,8 @@ models namespaces parser prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors sets ;
+concurrency.mailboxes ui.tools.workspace accessors sets
+destructors ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
@@ -110,9 +111,11 @@ M: interactor model-changed
} cleave
] [ drop f ] if ;
+: interactor-read ( interactor -- lines )
+ [ interactor-yield ] [ interactor-finish ] bi ;
+
M: interactor stream-readln
- [ interactor-yield ] [ interactor-finish ] bi
- dup [ first ] when ;
+ interactor-read dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
@@ -124,12 +127,22 @@ M: interactor stream-read
swap dup zero? [
2drop ""
] [
- >r stream-readln dup length r> min head
+ >r interactor-read dup [ "\n" join ] when r> short head
] if ;
M: interactor stream-read-partial
stream-read ;
+M: interactor stream-read1
+ dup interactor-read {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup empty? ] [ drop stream-read1 ] }
+ { [ dup first empty? ] [ 2drop CHAR: \n ] }
+ [ nip first first ]
+ } cond ;
+
+M: interactor dispose drop ;
+
: go-to-error ( interactor error -- )
[ line>> 1- ] [ column>> ] bi 2array
over set-caret
From fea65df1dfeb1f56bf40fb232aae99c430b2d731 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 23:07:26 +1200
Subject: [PATCH 20/85] Fix ebnf foreign call breakage and add tests
---
extra/peg/ebnf/ebnf-tests.factor | 36 +++++++++++++++++++++++++++++++-
extra/peg/ebnf/ebnf.factor | 6 +++---
2 files changed, 38 insertions(+), 4 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 04cc01c9d0..73db626685 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser
- sequences accessors ;
+ sequences accessors peg.parsers ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -397,4 +397,38 @@ main = Primary
{ t } [
"number=digit+:n 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+<<
+EBNF: parser1
+foo='a'
+;EBNF
+>>
+
+EBNF: parser2
+foo=<foreign parser1 foo> 'b'
+;EBNF
+
+EBNF: parser3
+foo=<foreign parser1> 'c'
+;EBNF
+
+EBNF: parser4
+foo=<foreign any-char> 'd'
+;EBNF
+
+{ "a" } [
+ "a" parser1 ast>>
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" parser2 ast>>
+] unit-test
+
+{ V{ "a" "c" } } [
+ "ac" parser3 ast>>
+] unit-test
+
+{ V{ CHAR: a "d" } } [
+ "ad" parser4 ast>>
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 36b3742b64..2ee0958051 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -415,11 +415,11 @@ M: ebnf-terminal (transform) ( ast -- parser )
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
[ "Foreign word " swap word>> append " not found" append throw ] unless*
- swap rule>> dup [
- swap rule
+ swap rule>> [ main ] unless* dupd swap rule [
+ nip
] [
execute
- ] if ;
+ ] if* ;
: parser-not-found ( name -- * )
[
From ea6974d5dac52706a67666a50ecaf22c915280eb Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 18 Jun 2008 23:50:25 +1200
Subject: [PATCH 21/85] Add \r to whitespace in javascript tokenizer
---
extra/peg/javascript/javascript.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 030d2f1728..127b13130a 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -52,7 +52,7 @@ Digit = [0-9]
Digits = Digit+
SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
-Space = " " | "\t" | "\n" | SingleLineComment | MultiLineComment
+Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
Spaces = Space* => [[ ignore ]]
NameFirst = Letter | "$" | "_"
NameRest = NameFirst | Digit
From 6f8e2a4b0ddf74ea0f7bd43aed53984faaceab9e Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 00:42:11 +1200
Subject: [PATCH 22/85] Refactor JavaScript parser
---
extra/peg/javascript/ast/ast.factor | 42 ++++
extra/peg/javascript/ast/authors.txt | 1 +
extra/peg/javascript/ast/summary.txt | 1 +
extra/peg/javascript/ast/tags.txt | 3 +
extra/peg/javascript/authors.txt | 1 +
extra/peg/javascript/javascript-docs.factor | 14 ++
extra/peg/javascript/javascript-tests.factor | 39 +--
extra/peg/javascript/javascript.factor | 225 +-----------------
extra/peg/javascript/parser/authors.txt | 1 +
.../peg/javascript/parser/parser-tests.factor | 27 +++
extra/peg/javascript/parser/parser.factor | 121 ++++++++++
extra/peg/javascript/parser/summary.txt | 1 +
extra/peg/javascript/parser/tags.txt | 3 +
extra/peg/javascript/summary.txt | 1 +
extra/peg/javascript/tags.txt | 3 +
extra/peg/javascript/tokenizer/authors.txt | 1 +
extra/peg/javascript/tokenizer/summary.txt | 1 +
extra/peg/javascript/tokenizer/tags.txt | 3 +
.../tokenizer/tokenizer-tests.factor | 23 ++
.../peg/javascript/tokenizer/tokenizer.factor | 68 ++++++
20 files changed, 330 insertions(+), 249 deletions(-)
create mode 100644 extra/peg/javascript/ast/ast.factor
create mode 100644 extra/peg/javascript/ast/authors.txt
create mode 100644 extra/peg/javascript/ast/summary.txt
create mode 100644 extra/peg/javascript/ast/tags.txt
create mode 100644 extra/peg/javascript/authors.txt
create mode 100644 extra/peg/javascript/javascript-docs.factor
create mode 100644 extra/peg/javascript/parser/authors.txt
create mode 100644 extra/peg/javascript/parser/parser-tests.factor
create mode 100644 extra/peg/javascript/parser/parser.factor
create mode 100644 extra/peg/javascript/parser/summary.txt
create mode 100644 extra/peg/javascript/parser/tags.txt
create mode 100644 extra/peg/javascript/summary.txt
create mode 100644 extra/peg/javascript/tags.txt
create mode 100644 extra/peg/javascript/tokenizer/authors.txt
create mode 100644 extra/peg/javascript/tokenizer/summary.txt
create mode 100644 extra/peg/javascript/tokenizer/tags.txt
create mode 100644 extra/peg/javascript/tokenizer/tokenizer-tests.factor
create mode 100644 extra/peg/javascript/tokenizer/tokenizer.factor
diff --git a/extra/peg/javascript/ast/ast.factor b/extra/peg/javascript/ast/ast.factor
new file mode 100644
index 0000000000..b857dc51bb
--- /dev/null
+++ b/extra/peg/javascript/ast/ast.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: peg.javascript.ast
+
+TUPLE: ast-keyword value ;
+TUPLE: ast-name value ;
+TUPLE: ast-number value ;
+TUPLE: ast-string value ;
+TUPLE: ast-regexp value ;
+TUPLE: ast-cond-expr condition then else ;
+TUPLE: ast-set lhs rhs ;
+TUPLE: ast-get value ;
+TUPLE: ast-mset lhs rhs operator ;
+TUPLE: ast-binop lhs rhs operator ;
+TUPLE: ast-unop expr operator ;
+TUPLE: ast-postop expr operator ;
+TUPLE: ast-preop expr operator ;
+TUPLE: ast-getp index expr ;
+TUPLE: ast-send method expr args ;
+TUPLE: ast-call expr args ;
+TUPLE: ast-this ;
+TUPLE: ast-new name args ;
+TUPLE: ast-array values ;
+TUPLE: ast-json bindings ;
+TUPLE: ast-binding name value ;
+TUPLE: ast-func fs body ;
+TUPLE: ast-var name value ;
+TUPLE: ast-begin statements ;
+TUPLE: ast-if condition true false ;
+TUPLE: ast-while condition statements ;
+TUPLE: ast-do-while statements condition ;
+TUPLE: ast-for i c u statements ;
+TUPLE: ast-for-in v e statements ;
+TUPLE: ast-switch expr statements ;
+TUPLE: ast-break ;
+TUPLE: ast-continue ;
+TUPLE: ast-throw e ;
+TUPLE: ast-try t e c f ;
+TUPLE: ast-return e ;
+TUPLE: ast-case c cs ;
+TUPLE: ast-default cs ;
diff --git a/extra/peg/javascript/ast/authors.txt b/extra/peg/javascript/ast/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/peg/javascript/ast/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/peg/javascript/ast/summary.txt b/extra/peg/javascript/ast/summary.txt
new file mode 100644
index 0000000000..543a2e6373
--- /dev/null
+++ b/extra/peg/javascript/ast/summary.txt
@@ -0,0 +1 @@
+Abstract Syntax Tree for JavaScript parser
diff --git a/extra/peg/javascript/ast/tags.txt b/extra/peg/javascript/ast/tags.txt
new file mode 100644
index 0000000000..c2aac2932f
--- /dev/null
+++ b/extra/peg/javascript/ast/tags.txt
@@ -0,0 +1,3 @@
+text
+javascript
+parsing
diff --git a/extra/peg/javascript/authors.txt b/extra/peg/javascript/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/peg/javascript/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/peg/javascript/javascript-docs.factor b/extra/peg/javascript/javascript-docs.factor
new file mode 100644
index 0000000000..5fdc3e8587
--- /dev/null
+++ b/extra/peg/javascript/javascript-docs.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: peg.javascript
+
+HELP: parse-javascript
+{ $values
+ { "string" "a string" }
+ { "ast" "a JavaScript abstract syntax tree" }
+}
+{ $description
+ "Parse the input string using the JavaScript parser. Throws an error if "
+ "the string does not contain valid JavaScript. Returns the abstract syntax tree "
+ "if successful." } ;
diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor
index 70410a3838..0d6899714d 100644
--- a/extra/peg/javascript/javascript-tests.factor
+++ b/extra/peg/javascript/javascript-tests.factor
@@ -1,42 +1,11 @@
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.javascript accessors ;
+USING: kernel tools.test peg.javascript peg.javascript.ast accessors ;
IN: peg.javascript.tests
-\ javascript must-infer
+\ parse-javascript must-infer
-{
- V{
- T{ ast-number f 123 }
- ";"
- T{ ast-string f "hello" }
- ";"
- T{ ast-name f "foo" }
- "("
- T{ ast-name f "x" }
- ")"
- ";"
- }
-} [
- "123; 'hello'; foo(x);" tokenizer ast>>
-] unit-test
-
-{
- T{
- ast-begin
- f
- V{
- T{ ast-number f 123 }
- T{ ast-string f "hello" }
- T{
- ast-call
- f
- T{ ast-get f "foo" }
- V{ T{ ast-get f "x" } }
- }
- }
- }
-} [
- "123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
+{ T{ ast-begin f V{ T{ ast-number f 123 } } } } [
+ "123;" parse-javascript
] unit-test
\ No newline at end of file
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 127b13130a..23a4b4f7f0 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -1,219 +1,16 @@
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays strings math.parser sequences sequences.deep
-peg peg.ebnf peg.parsers memoize namespaces math accessors ;
+USING: kernel accessors peg.javascript.tokenizer peg.javascript.parser ;
IN: peg.javascript
-#! Grammar for JavaScript. Based on OMeta-JS example from:
-#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+: parse-javascript ( string -- ast )
+ tokenizer [
+ ast>> javascript [
+ ast>>
+ ] [
+ "Unable to parse JavaScript" throw
+ ] if*
+ ] [
+ "Unable to tokenize JavaScript" throw
+ ] if* ;
-USE: prettyprint
-
-TUPLE: ast-keyword value ;
-TUPLE: ast-name value ;
-TUPLE: ast-number value ;
-TUPLE: ast-string value ;
-TUPLE: ast-cond-expr condition then else ;
-TUPLE: ast-set lhs rhs ;
-TUPLE: ast-get value ;
-TUPLE: ast-mset lhs rhs operator ;
-TUPLE: ast-binop lhs rhs operator ;
-TUPLE: ast-unop expr operator ;
-TUPLE: ast-postop expr operator ;
-TUPLE: ast-preop expr operator ;
-TUPLE: ast-getp index expr ;
-TUPLE: ast-send method expr args ;
-TUPLE: ast-call expr args ;
-TUPLE: ast-this ;
-TUPLE: ast-new name args ;
-TUPLE: ast-array values ;
-TUPLE: ast-json bindings ;
-TUPLE: ast-binding name value ;
-TUPLE: ast-func fs body ;
-TUPLE: ast-var name value ;
-TUPLE: ast-begin statements ;
-TUPLE: ast-if condition true false ;
-TUPLE: ast-while condition statements ;
-TUPLE: ast-do-while statements condition ;
-TUPLE: ast-for i c u statements ;
-TUPLE: ast-for-in v e statements ;
-TUPLE: ast-switch expr statements ;
-TUPLE: ast-break ;
-TUPLE: ast-continue ;
-TUPLE: ast-throw e ;
-TUPLE: ast-try t e c f ;
-TUPLE: ast-return e ;
-TUPLE: ast-case c cs ;
-TUPLE: ast-default cs ;
-
-EBNF: tokenizer
-Letter = [a-zA-Z]
-Digit = [0-9]
-Digits = Digit+
-SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
-MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
-Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
-Spaces = Space* => [[ ignore ]]
-NameFirst = Letter | "$" | "_"
-NameRest = NameFirst | Digit
-iName = NameFirst NameRest* => [[ first2 swap prefix >string ]]
-Keyword = ("break"
- | "case"
- | "catch"
- | "continue"
- | "default"
- | "delete"
- | "do"
- | "else"
- | "finally"
- | "for"
- | "function"
- | "if"
- | "in"
- | "instanceof"
- | "new"
- | "return"
- | "switch"
- | "this"
- | "throw"
- | "try"
- | "typeof"
- | "var"
- | "void"
- | "while"
- | "with")
-Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
-Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
- | Digits => [[ >string string>number ast-number boa ]]
-
-EscapeChar = "\\n" => [[ 10 ]]
- | "\\r" => [[ 13 ]]
- | "\\t" => [[ 9 ]]
-StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
-StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
-StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
-Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
- | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
- | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
-Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
- | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
- | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
- | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
- | "&&" | "||=" | "||" | "." | "!"
-Tok = Spaces (Name | Keyword | Number | Str | Special )
-Toks = Tok* Spaces
-;EBNF
-
-EBNF: javascript
-Space = " " | "\t" | "\n"
-Spaces = Space* => [[ ignore ]]
-Name = . ?[ ast-name? ]? => [[ value>> ]]
-Number = . ?[ ast-number? ]? => [[ value>> ]]
-String = . ?[ ast-string? ]? => [[ value>> ]]
-SpacesNoNl = (!("\n") Space)* => [[ ignore ]]
-
-Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
- | OrExpr:e "=" Expr:rhs => [[ e rhs ast-set boa ]]
- | OrExpr:e "+=" Expr:rhs => [[ e rhs "+" ast-mset boa ]]
- | OrExpr:e "-=" Expr:rhs => [[ e rhs "-" ast-mset boa ]]
- | OrExpr:e "*=" Expr:rhs => [[ e rhs "*" ast-mset boa ]]
- | OrExpr:e "/=" Expr:rhs => [[ e rhs "/" ast-mset boa ]]
- | OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]]
- | OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]]
- | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]]
- | OrExpr:e => [[ e ]]
-
-OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]]
- | AndExpr
-AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]]
- | EqExpr
-EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]]
- | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]]
- | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]]
- | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]]
- | RelExpr
-RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]]
- | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]]
- | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]]
- | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]]
- | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]]
- | AddExpr
-AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
- | AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
- | MulExpr
-MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
- | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
- | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
- | Unary
-Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
- | "+" Postfix:p => [[ p ]]
- | "++" Postfix:p => [[ p "++" ast-preop boa ]]
- | "--" Postfix:p => [[ p "--" ast-preop boa ]]
- | "!" Postfix:p => [[ p "!" ast-unop boa ]]
- | Postfix
-Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
- | PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
- | PrimExpr
-Args = (Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]])?
-PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
- | PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
- | PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
- | PrimExpr:p "(" Args:as ")" => [[ p as ast-call boa ]]
- | PrimExprHd
-PrimExprHd = "(" Expr:e ")" => [[ e ]]
- | "this" => [[ ast-this boa ]]
- | Name => [[ ast-get boa ]]
- | Number => [[ ast-number boa ]]
- | String => [[ ast-string boa ]]
- | "function" FuncRest:fr => [[ fr ]]
- | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
- | "[" Args:es "]" => [[ es ast-array boa ]]
- | Json
-JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
-Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
-JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
-JsonPropName = Name | Number | String
-Formal = Spaces Name
-Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
-FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
-Sc = SpacesNoNl ("\n" | &("}"))| ";"
-Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
- | Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
-Block = "{" SrcElems:ss "}" => [[ ss ]]
-Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])?
-For1 = "var" Binding => [[ second ]]
- | Expr
- | Spaces => [[ "undefined" ast-get boa ]]
-For2 = Expr
- | Spaces => [[ "true" ast-get boa ]]
-For3 = Expr
- | Spaces => [[ "undefined" ast-get boa ]]
-ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
- | Expr
-Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
- | "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
-SwitchBody = Switch1*
-Finally = "finally" Block:b => [[ b ]]
- | Spaces => [[ "undefined" ast-get boa ]]
-Stmt = Block
- | "var" Bindings:bs Sc => [[ bs ast-begin boa ]]
- | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ c t f ast-if boa ]]
- | "if" "(" Expr:c ")" Stmt:t => [[ c t "undefined" ast-get boa ast-if boa ]]
- | "while" "(" Expr:c ")" Stmt:s => [[ c s ast-while boa ]]
- | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ s c ast-do-while boa ]]
- | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ i c u s ast-for boa ]]
- | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ v e s ast-for-in boa ]]
- | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ e cs ast-switch boa ]]
- | "break" Sc => [[ ast-break boa ]]
- | "continue" Sc => [[ ast-continue boa ]]
- | "throw" SpacesNoNl Expr:e Sc => [[ e ast-throw boa ]]
- | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]]
- | "return" Expr:e Sc => [[ e ast-return boa ]]
- | "return" Sc => [[ "undefined" ast-get boa ast-return boa ]]
- | Expr:e Sc => [[ e ]]
- | ";" => [[ "undefined" ast-get boa ]]
-SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
- | Stmt
-SrcElems = SrcElem* => [[ ast-begin boa ]]
-TopLevel = SrcElems Spaces
-;EBNF
\ No newline at end of file
diff --git a/extra/peg/javascript/parser/authors.txt b/extra/peg/javascript/parser/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/peg/javascript/parser/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
new file mode 100644
index 0000000000..933d4cf10e
--- /dev/null
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer
+ peg.javascript.parser accessors ;
+IN: peg.javascript.parser.tests
+
+\ javascript must-infer
+
+{
+ T{
+ ast-begin
+ f
+ V{
+ T{ ast-number f 123 }
+ T{ ast-string f "hello" }
+ T{
+ ast-call
+ f
+ T{ ast-get f "foo" }
+ V{ T{ ast-get f "x" } }
+ }
+ }
+ }
+} [
+ "123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
new file mode 100644
index 0000000000..a38cf4aea8
--- /dev/null
+++ b/extra/peg/javascript/parser/parser.factor
@@ -0,0 +1,121 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors peg peg.ebnf peg.javascript.ast ;
+IN: peg.javascript.parser
+
+#! Grammar for JavaScript. Based on OMeta-JS example from:
+#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+
+EBNF: javascript
+Space = " " | "\t" | "\n"
+Spaces = Space* => [[ ignore ]]
+Name = . ?[ ast-name? ]? => [[ value>> ]]
+Number = . ?[ ast-number? ]? => [[ value>> ]]
+String = . ?[ ast-string? ]? => [[ value>> ]]
+SpacesNoNl = (!("\n") Space)* => [[ ignore ]]
+
+Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
+ | OrExpr:e "=" Expr:rhs => [[ e rhs ast-set boa ]]
+ | OrExpr:e "+=" Expr:rhs => [[ e rhs "+" ast-mset boa ]]
+ | OrExpr:e "-=" Expr:rhs => [[ e rhs "-" ast-mset boa ]]
+ | OrExpr:e "*=" Expr:rhs => [[ e rhs "*" ast-mset boa ]]
+ | OrExpr:e "/=" Expr:rhs => [[ e rhs "/" ast-mset boa ]]
+ | OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]]
+ | OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]]
+ | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]]
+ | OrExpr:e => [[ e ]]
+
+OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]]
+ | AndExpr
+AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]]
+ | EqExpr
+EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]]
+ | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]]
+ | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]]
+ | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]]
+ | RelExpr
+RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]]
+ | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]]
+ | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]]
+ | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]]
+ | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]]
+ | AddExpr
+AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
+ | AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
+ | MulExpr
+MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
+ | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
+ | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
+ | Unary
+Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
+ | "+" Postfix:p => [[ p ]]
+ | "++" Postfix:p => [[ p "++" ast-preop boa ]]
+ | "--" Postfix:p => [[ p "--" ast-preop boa ]]
+ | "!" Postfix:p => [[ p "!" ast-unop boa ]]
+ | Postfix
+Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
+ | PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
+ | PrimExpr
+Args = (Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]])?
+PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
+ | PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
+ | PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
+ | PrimExpr:p "(" Args:as ")" => [[ p as ast-call boa ]]
+ | PrimExprHd
+PrimExprHd = "(" Expr:e ")" => [[ e ]]
+ | "this" => [[ ast-this boa ]]
+ | Name => [[ ast-get boa ]]
+ | Number => [[ ast-number boa ]]
+ | String => [[ ast-string boa ]]
+ | "function" FuncRest:fr => [[ fr ]]
+ | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "[" Args:es "]" => [[ es ast-array boa ]]
+ | Json
+JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
+Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
+JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
+JsonPropName = Name | Number | String
+Formal = Spaces Name
+Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
+FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
+Sc = SpacesNoNl ("\n" | &("}"))| ";"
+Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
+ | Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
+Block = "{" SrcElems:ss "}" => [[ ss ]]
+Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])?
+For1 = "var" Binding => [[ second ]]
+ | Expr
+ | Spaces => [[ "undefined" ast-get boa ]]
+For2 = Expr
+ | Spaces => [[ "true" ast-get boa ]]
+For3 = Expr
+ | Spaces => [[ "undefined" ast-get boa ]]
+ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
+ | Expr
+Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
+ | "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
+SwitchBody = Switch1*
+Finally = "finally" Block:b => [[ b ]]
+ | Spaces => [[ "undefined" ast-get boa ]]
+Stmt = Block
+ | "var" Bindings:bs Sc => [[ bs ast-begin boa ]]
+ | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ c t f ast-if boa ]]
+ | "if" "(" Expr:c ")" Stmt:t => [[ c t "undefined" ast-get boa ast-if boa ]]
+ | "while" "(" Expr:c ")" Stmt:s => [[ c s ast-while boa ]]
+ | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ s c ast-do-while boa ]]
+ | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ i c u s ast-for boa ]]
+ | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ v e s ast-for-in boa ]]
+ | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ e cs ast-switch boa ]]
+ | "break" Sc => [[ ast-break boa ]]
+ | "continue" Sc => [[ ast-continue boa ]]
+ | "throw" SpacesNoNl Expr:e Sc => [[ e ast-throw boa ]]
+ | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]]
+ | "return" Expr:e Sc => [[ e ast-return boa ]]
+ | "return" Sc => [[ "undefined" ast-get boa ast-return boa ]]
+ | Expr:e Sc => [[ e ]]
+ | ";" => [[ "undefined" ast-get boa ]]
+SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
+ | Stmt
+SrcElems = SrcElem* => [[ ast-begin boa ]]
+TopLevel = SrcElems Spaces
+;EBNF
\ No newline at end of file
diff --git a/extra/peg/javascript/parser/summary.txt b/extra/peg/javascript/parser/summary.txt
new file mode 100644
index 0000000000..bae5a461d2
--- /dev/null
+++ b/extra/peg/javascript/parser/summary.txt
@@ -0,0 +1 @@
+JavaScript Parser
diff --git a/extra/peg/javascript/parser/tags.txt b/extra/peg/javascript/parser/tags.txt
new file mode 100644
index 0000000000..c2aac2932f
--- /dev/null
+++ b/extra/peg/javascript/parser/tags.txt
@@ -0,0 +1,3 @@
+text
+javascript
+parsing
diff --git a/extra/peg/javascript/summary.txt b/extra/peg/javascript/summary.txt
new file mode 100644
index 0000000000..12f092dcf7
--- /dev/null
+++ b/extra/peg/javascript/summary.txt
@@ -0,0 +1 @@
+JavaScript parser
diff --git a/extra/peg/javascript/tags.txt b/extra/peg/javascript/tags.txt
new file mode 100644
index 0000000000..c2aac2932f
--- /dev/null
+++ b/extra/peg/javascript/tags.txt
@@ -0,0 +1,3 @@
+text
+javascript
+parsing
diff --git a/extra/peg/javascript/tokenizer/authors.txt b/extra/peg/javascript/tokenizer/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/peg/javascript/tokenizer/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/peg/javascript/tokenizer/summary.txt b/extra/peg/javascript/tokenizer/summary.txt
new file mode 100644
index 0000000000..ce94386ed9
--- /dev/null
+++ b/extra/peg/javascript/tokenizer/summary.txt
@@ -0,0 +1 @@
+Tokenizer for JavaScript language
diff --git a/extra/peg/javascript/tokenizer/tags.txt b/extra/peg/javascript/tokenizer/tags.txt
new file mode 100644
index 0000000000..c2aac2932f
--- /dev/null
+++ b/extra/peg/javascript/tokenizer/tags.txt
@@ -0,0 +1,3 @@
+text
+javascript
+parsing
diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
new file mode 100644
index 0000000000..1300b3c9c7
--- /dev/null
+++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
+IN: peg.javascript.tokenizer.tests
+
+\ tokenizer must-infer
+
+{
+ V{
+ T{ ast-number f 123 }
+ ";"
+ T{ ast-string f "hello" }
+ ";"
+ T{ ast-name f "foo" }
+ "("
+ T{ ast-name f "x" }
+ ")"
+ ";"
+ }
+} [
+ "123; 'hello'; foo(x);" tokenizer ast>>
+] unit-test
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
new file mode 100644
index 0000000000..d62bb9395b
--- /dev/null
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings arrays math.parser peg peg.ebnf peg.javascript.ast ;
+IN: peg.javascript.tokenizer
+
+#! Grammar for JavaScript. Based on OMeta-JS example from:
+#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+
+EBNF: tokenizer
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = Digit+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
+Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
+Spaces = Space* => [[ ignore ]]
+NameFirst = Letter | "$" | "_"
+NameRest = NameFirst | Digit
+iName = NameFirst NameRest* => [[ first2 swap prefix >string ]]
+Keyword = ("break"
+ | "case"
+ | "catch"
+ | "continue"
+ | "default"
+ | "delete"
+ | "do"
+ | "else"
+ | "finally"
+ | "for"
+ | "function"
+ | "if"
+ | "in"
+ | "instanceof"
+ | "new"
+ | "return"
+ | "switch"
+ | "this"
+ | "throw"
+ | "try"
+ | "typeof"
+ | "var"
+ | "void"
+ | "while"
+ | "with")
+Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
+
+EscapeChar = "\\n" => [[ 10 ]]
+ | "\\r" => [[ 13 ]]
+ | "\\t" => [[ 9 ]]
+StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
+StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
+StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
+Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
+ | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
+ | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
+RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]]
+RegExp = "/" RegExpBody:r "/" => [[ r ast-regexp boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special )
+Toks = Tok* Spaces
+;EBNF
+
From fc7baebacbcedc177b16c5377991e156e9f62d26 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 00:51:47 +1200
Subject: [PATCH 23/85] Fix handling of _ and $ in Javascript names
---
extra/peg/javascript/tokenizer/tokenizer.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index d62bb9395b..420abff442 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -6,6 +6,8 @@ IN: peg.javascript.tokenizer
#! Grammar for JavaScript. Based on OMeta-JS example from:
#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+USE: prettyprint
+
EBNF: tokenizer
Letter = [a-zA-Z]
Digit = [0-9]
@@ -14,7 +16,7 @@ SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
Spaces = Space* => [[ ignore ]]
-NameFirst = Letter | "$" | "_"
+NameFirst = Letter | "$" => [[ CHAR: $ ]] | "_" => [[ CHAR: _ ]]
NameRest = NameFirst | Digit
iName = NameFirst NameRest* => [[ first2 swap prefix >string ]]
Keyword = ("break"
From c26d87e11788c107d7467f38ae2a0bded3666c05 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:01:46 +1200
Subject: [PATCH 24/85] Fix handling of JavasScript names which partially match
reserved words
---
extra/peg/javascript/tokenizer/tokenizer.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index 420abff442..70fabb10f6 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -44,7 +44,7 @@ Keyword = ("break"
| "void"
| "while"
| "with")
-Name = !(Keyword) (iName):n => [[ n ast-name boa ]]
+Name = iName !(Keyword) => [[ ast-name boa ]]
Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
From 179ea21c11d95f257a5f3172dab4ffd7fa91ae5a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:10:44 +1200
Subject: [PATCH 25/85] Add a couple of failing peg.ebnf tests
---
extra/peg/ebnf/ebnf-tests.factor | 12 +++++++++++-
1 file changed, 11 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 73db626685..ed38d37421 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -399,6 +399,16 @@ main = Primary
"number=digit+:n 'a'" 'ebnf' parse remaining>> length zero?
] unit-test
+{ t } [
+ "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse ast>>
+ "foo=name:n !(keyword) => [[ n ]]" 'rule' parse ast>> =
+] unit-test
+
+{ t } [
+ "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse ast>>
+ "foo=!(keyword) name:n => [[ n ]]" 'rule' parse ast>> =
+] unit-test
+
<<
EBNF: parser1
foo='a'
@@ -431,4 +441,4 @@ foo=<foreign any-char> 'd'
{ V{ CHAR: a "d" } } [
"ad" parser4 ast>>
-] unit-test
\ No newline at end of file
+] unit-test
From fcd1e39834052d7df4548d4c411870a8417ec10c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:20:33 +1200
Subject: [PATCH 26/85] More JavaScript fixes for keyword handling
---
extra/peg/javascript/tokenizer/tokenizer.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index 70fabb10f6..a1cff8a3db 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -43,8 +43,8 @@ Keyword = ("break"
| "var"
| "void"
| "while"
- | "with")
-Name = iName !(Keyword) => [[ ast-name boa ]]
+ | "with") !(NameRest)
+Name = !(Keyword) iName => [[ ast-name boa ]]
Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
From d58a085598e930566c003aaff406e5996f91c73f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:24:17 +1200
Subject: [PATCH 27/85] Add additional javascript test
---
extra/peg/javascript/parser/parser-tests.factor | 14 ++++++++++++--
1 file changed, 12 insertions(+), 2 deletions(-)
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index 933d4cf10e..6741e059f9 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer
- peg.javascript.parser accessors ;
+ peg.javascript.parser accessors multiline sequences math ;
IN: peg.javascript.parser.tests
\ javascript must-infer
@@ -24,4 +24,14 @@ IN: peg.javascript.parser.tests
}
} [
"123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
-] unit-test
\ No newline at end of file
+] unit-test
+
+{ t } [
+<"
+function foldl(f, initial, seq) {
+ for(var i=0; i< seq.length; ++i)
+ initial = f(initial, seq[i]);
+ return initial;
+}
+"> tokenizer ast>> javascript remaining>> length zero?
+] unit-test
From d5e5e47944736585195b66aab7e997b0e7c9a666 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:39:51 +1200
Subject: [PATCH 28/85] Fix bug in javascript automatic semicolon insertion
rule
---
extra/peg/javascript/parser/parser-tests.factor | 11 +++++++++++
extra/peg/javascript/parser/parser.factor | 3 ++-
2 files changed, 13 insertions(+), 1 deletion(-)
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index 6741e059f9..ec7a30845f 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -35,3 +35,14 @@ function foldl(f, initial, seq) {
}
"> tokenizer ast>> javascript remaining>> length zero?
] unit-test
+
+{ t } [
+<"
+ParseState.prototype.from = function(index) {
+ var r = new ParseState(this.input, this.index + index);
+ r.cache = this.cache;
+ r.length = this.length - index;
+ return r;
+}
+"> tokenizer ast>> javascript remaining>> length zero?
+] unit-test
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index a38cf4aea8..45aa0f022c 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -7,6 +7,7 @@ IN: peg.javascript.parser
#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
EBNF: javascript
+End = !(.)
Space = " " | "\t" | "\n"
Spaces = Space* => [[ ignore ]]
Name = . ?[ ast-name? ]? => [[ value>> ]]
@@ -78,7 +79,7 @@ JsonPropName = Name | Number | String
Formal = Spaces Name
Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
-Sc = SpacesNoNl ("\n" | &("}"))| ";"
+Sc = SpacesNoNl ("\n" | &("}") | End)| ";"
Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
From 2b2ede0a89411421649af182bb69439bc6424b17 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 01:45:09 +1200
Subject: [PATCH 29/85] Add a javascript sc test
---
extra/peg/javascript/parser/parser-tests.factor | 9 +++++++++
1 file changed, 9 insertions(+)
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index ec7a30845f..d911a27285 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -26,6 +26,14 @@ IN: peg.javascript.parser.tests
"123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
] unit-test
+{ t } [
+<"
+var x=5
+var y=10
+"> tokenizer ast>> javascript remaining>> length zero?
+] unit-test
+
+
{ t } [
<"
function foldl(f, initial, seq) {
@@ -46,3 +54,4 @@ ParseState.prototype.from = function(index) {
}
"> tokenizer ast>> javascript remaining>> length zero?
] unit-test
+
From 3e11a7f2040d89271113fcc5ffe2cbebd43afe52 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 19:46:37 -0500
Subject: [PATCH 30/85] Debugging persistent vectors
---
.../persistent-vectors-tests.factor | 4 +++
.../persistent-vectors.factor | 33 ++++++++++++-------
2 files changed, 25 insertions(+), 12 deletions(-)
diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor
index a4e4ad33fe..45eb894e67 100644
--- a/extra/persistent-vectors/persistent-vectors-tests.factor
+++ b/extra/persistent-vectors/persistent-vectors-tests.factor
@@ -48,6 +48,10 @@ random namespaces vectors math math.order ;
[ ] [ PV{ } "1" set ] unit-test
[ ] [ V{ } clone "2" set ] unit-test
+: push/pop-test ( vec -- vec' ) 3 swap ppush 3 swap ppush ppop ;
+
+[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
+
[ t ] [
100 [
drop
diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor
index f9f4b68933..c80de3b0cd 100644
--- a/extra/persistent-vectors/persistent-vectors.factor
+++ b/extra/persistent-vectors/persistent-vectors.factor
@@ -1,7 +1,7 @@
! Based on Clojure's PersistentVector by Rich Hickey.
USING: math accessors kernel sequences.private sequences arrays
-combinators parser prettyprint.backend ;
+combinators combinators.lib parser prettyprint.backend ;
IN: persistent-vectors
ERROR: empty-error pvec ;
@@ -123,30 +123,39 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
] if
] if ;
+: ppop-tail ( pvec -- pvec' )
+ [ clone [ ppop ] change-children ] change-tail ;
+
: (ppop-contraction) ( node -- node' tail' )
clone [ unclip-last swap ] change-children swap ;
: ppop-contraction ( node -- node' tail' )
- [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
+ dup children>> length 1 =
+ [ children>> peek f swap ]
+ [ (ppop-contraction) ]
+ if ;
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
- dup children>> peek (ppop-new-tail) over children>> empty?
- [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
+ dup children>> peek (ppop-new-tail) over
+ [ [ swap node-set-last ] dip ]
+ [ 2drop ppop-contraction ]
+ if
] [
ppop-contraction
] if ;
-: ppop-tail ( pvec -- pvec' )
- [ clone [ ppop ] change-children ] change-tail ;
+: trivial? ( node -- ? )
+ { [ level>> 1 > ] [ children>> length 1 = ] } 1&& ;
: ppop-new-tail ( pvec -- pvec' )
- dup root>> (ppop-new-tail)
- [
- dup [ level>> 1 > ] [ children>> length 1 = ] bi and
- [ children>> first ] when
- ] dip
- [ >>root ] [ >>tail ] bi* ;
+ dup root>> (ppop-new-tail) [
+ {
+ { [ dup not ] [ drop T{ node f { } 1 } ] }
+ { [ dup trivial? ] [ children>> first ] }
+ [ ]
+ } cond
+ ] dip [ >>root ] [ >>tail ] bi* ;
PRIVATE>
From 04453b242157e5966971fd86dc62c86ab6a56757 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 14:23:18 +1200
Subject: [PATCH 31/85] Fix (foo):n usage
---
extra/peg/ebnf/ebnf.factor | 20 ++++++++++++--------
1 file changed, 12 insertions(+), 8 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 2ee0958051..d982d73229 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -232,14 +232,18 @@ DEFER: 'choice'
: ('sequence') ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
- [
- 'ensure-not' sp ,
- 'ensure' sp ,
- 'element' sp ,
- 'group' sp ,
- 'repeat0' sp ,
- 'repeat1' sp ,
- 'optional' sp ,
+ [
+ [
+ 'ensure-not' sp ,
+ 'ensure' sp ,
+ 'element' sp ,
+ 'group' sp ,
+ 'repeat0' sp ,
+ 'repeat1' sp ,
+ 'optional' sp ,
+ ] choice*
+ [ dup , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
+ ,
] choice* ;
: 'action' ( -- parser )
From 3dc3a6f8996d46f3717302407b197d3b0aa6da1a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 14:31:14 +1200
Subject: [PATCH 32/85] Remove obsolete ebnf stuff
---
extra/peg/ebnf/ebnf.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index d982d73229..08ac24e535 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -266,8 +266,6 @@ DEFER: 'choice'
: 'actioned-sequence' ( -- parser )
[
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
- [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r <ebnf-var> r> <ebnf-action> ] action ,
- [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
'sequence' ,
] choice* ;
From c92224f5b9b94ea2bdc1224c10cf640921c283df Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 14:34:09 +1200
Subject: [PATCH 33/85] Put '..' around parser error messages
---
extra/peg/ebnf/ebnf.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 08ac24e535..2aec8b9aea 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -416,7 +416,7 @@ M: ebnf-terminal (transform) ( ast -- parser )
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
- [ "Foreign word " swap word>> append " not found" append throw ] unless*
+ [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
swap rule>> [ main ] unless* dupd swap rule [
nip
] [
@@ -425,7 +425,7 @@ M: ebnf-foreign (transform) ( ast -- parser )
: parser-not-found ( name -- * )
[
- "Parser " % % " not found." %
+ "Parser '" % % "' not found." %
] "" make throw ;
M: ebnf-non-terminal (transform) ( ast -- parser )
From 9b7e2bacc960c03ff28780b0a469018a098b5540 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 19 Jun 2008 14:44:13 +1200
Subject: [PATCH 34/85] Throw an error if there are duplicate rules in ebnf
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 2aec8b9aea..e78757be34 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -305,7 +305,7 @@ M: ebnf (transform) ( ast -- parser )
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
- swap symbol>> set
+ swap symbol>> dup get [ "Rule '" over append "' defined more than once" append throw ] [ set ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
From beccf83f7ccb81ddf35f025d22450b8ae51bbca5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 22:29:48 -0500
Subject: [PATCH 35/85] Fix deploy tests
---
extra/tools/deploy/deploy-tests.factor | 22 +++++++++++++---------
extra/tools/deploy/test/3/3.factor | 5 ++---
extra/tools/deploy/test/4/4.factor | 7 +++++++
extra/tools/deploy/test/4/deploy.factor | 15 +++++++++++++++
4 files changed, 37 insertions(+), 12 deletions(-)
create mode 100644 extra/tools/deploy/test/4/4.factor
create mode 100644 extra/tools/deploy/test/4/deploy.factor
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 8ff22fb1ad..5309784b7c 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -49,12 +49,16 @@ namespaces continuations layouts accessors ;
cell 8 = 50 30 ? 100000 * small-enough?
] unit-test
-[ ] [
- "tools.deploy.test.1" shake-and-bake
- vm "-i=" "test.image" temp-file append 2array try-process
-] unit-test
-
-[ ] [
- "tools.deploy.test.2" shake-and-bake
- vm "-i=" "test.image" temp-file append 2array try-process
-] unit-test
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process
+ ] curry unit-test
+] each
diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor
index 69287db4e2..5919fa15db 100755
--- a/extra/tools/deploy/test/3/3.factor
+++ b/extra/tools/deploy/test/3/3.factor
@@ -1,8 +1,7 @@
IN: tools.deploy.test.3
-USING: io.encodings.ascii io.files kernel ;
+USING: io.encodings.ascii io.encodings.string system kernel ;
: deploy-test-3 ( -- )
- "resource:extra/tools/deploy/test/3/3.factor"
- ascii file-contents drop ;
+ "xyzthg" ascii encode drop ;
MAIN: deploy-test-3
diff --git a/extra/tools/deploy/test/4/4.factor b/extra/tools/deploy/test/4/4.factor
new file mode 100644
index 0000000000..6831eae5d3
--- /dev/null
+++ b/extra/tools/deploy/test/4/4.factor
@@ -0,0 +1,7 @@
+IN: tools.deploy.test.4
+USING: io.encodings.8-bit io.encodings.string kernel ;
+
+: deploy-test-4 ( -- )
+ "xyzthg" latin7 encode drop ;
+
+MAIN: deploy-test-4
diff --git a/extra/tools/deploy/test/4/deploy.factor b/extra/tools/deploy/test/4/deploy.factor
new file mode 100644
index 0000000000..5250ad698a
--- /dev/null
+++ b/extra/tools/deploy/test/4/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-math? f }
+ { deploy-ui? f }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-io 2 }
+ { deploy-name "tools.deploy.test.4" }
+ { deploy-c-types? f }
+ { deploy-random? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-reflection 1 }
+}
From ce8c3cd38907ddcc248aaa33d10ef0a612d0c2c3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 22:30:54 -0500
Subject: [PATCH 36/85] Clean up UI a bit
---
extra/boids/ui/ui.factor | 8 ++---
extra/gesture-logger/gesture-logger.factor | 6 ++--
extra/lsys/ui/ui.factor | 6 ++--
extra/ui/gadgets/buttons/buttons.factor | 29 +++++++++---------
extra/ui/gadgets/canvas/canvas.factor | 2 +-
extra/ui/gadgets/labelled/labelled.factor | 2 +-
extra/ui/gadgets/labels/labels.factor | 28 ++++++++---------
extra/ui/gadgets/lists/lists.factor | 15 +++++-----
extra/ui/gadgets/menus/menus.factor | 6 ++--
extra/ui/gadgets/panes/panes.factor | 30 ++++++++-----------
extra/ui/gadgets/scrollers/scrollers.factor | 2 +-
extra/ui/gadgets/sliders/sliders.factor | 13 ++++----
extra/ui/gadgets/status-bar/status-bar.factor | 10 +++----
extra/ui/gadgets/theme/theme.factor | 14 ++++-----
14 files changed, 84 insertions(+), 87 deletions(-)
diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor
index a1feac381d..0753f4eb06 100755
--- a/extra/boids/ui/ui.factor
+++ b/extra/boids/ui/ui.factor
@@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
- "" <label> dup reverse-video-theme >population-label update-population-label
+ "" <label> reverse-video-theme >population-label update-population-label
- "" <label> dup reverse-video-theme >cohesion-label update-cohesion-label
- "" <label> dup reverse-video-theme >alignment-label update-alignment-label
- "" <label> dup reverse-video-theme >separation-label update-separation-label
+ "" <label> reverse-video-theme >cohesion-label update-cohesion-label
+ "" <label> reverse-video-theme >alignment-label update-alignment-label
+ "" <label> reverse-video-theme >separation-label update-separation-label
<frame>
diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor
index b9de7c1b74..76615a3de5 100644
--- a/extra/gesture-logger/gesture-logger.factor
+++ b/extra/gesture-logger/gesture-logger.factor
@@ -8,9 +8,9 @@ TUPLE: gesture-logger stream ;
: <gesture-logger> ( stream -- gadget )
\ gesture-logger construct-gadget
- [ set-gesture-logger-stream ] keep
- { 100 100 } over set-rect-dim
- dup black solid-interior ;
+ swap >>stream
+ { 100 100 } >>dim
+ black solid-interior ;
M: gesture-logger handle-gesture*
drop
diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor
index c3b9190c3c..1365301897 100644
--- a/extra/lsys/ui/ui.factor
+++ b/extra/lsys/ui/ui.factor
@@ -100,17 +100,17 @@ DEFER: empty-model
{
-[ "Load" <label> dup reverse-video-theme ]
+[ "Load" <label> reverse-video-theme ]
[ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
[ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
-[ "Model" <label> dup reverse-video-theme ]
+[ "Model" <label> reverse-video-theme ]
[ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
[ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
-[ "Camera" <label> dup reverse-video-theme ]
+[ "Camera" <label> reverse-video-theme ]
[ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
[ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index e452e6c455..c36d2050c9 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -41,7 +41,7 @@ button H{
: <button> ( gadget quot -- button )
button new
- [ set-button-quot ] keep
+ swap >>quot
[ set-gadget-delegate ] keep ;
TUPLE: button-paint plain rollover pressed selected ;
@@ -53,10 +53,10 @@ C: <button-paint> button-paint
: button-paint ( button paint -- button paint )
over find-button {
- { [ dup button-pressed? ] [ drop button-paint-pressed ] }
- { [ dup button-selected? ] [ drop button-paint-selected ] }
- { [ dup button-rollover? ] [ drop button-paint-rollover ] }
- [ drop button-paint-plain ]
+ { [ dup pressed?>> ] [ drop pressed>> ] }
+ { [ dup selected?>> ] [ drop selected>> ] }
+ { [ dup button-rollover? ] [ drop rollover>> ] }
+ [ drop plain>> ]
} cond ;
M: button-paint draw-interior
@@ -65,25 +65,26 @@ M: button-paint draw-interior
M: button-paint draw-boundary
button-paint draw-boundary ;
-: roll-button-theme ( button -- )
- f black <solid> dup f <button-paint>
- swap set-gadget-boundary ;
+: roll-button-theme ( button -- button )
+ f black <solid> dup f <button-paint> >>boundary ; inline
: <roll-button> ( label quot -- button )
- >r >label r>
- <button> dup roll-button-theme ;
+ >r >label r> <button> roll-button-theme ;
-: bevel-button-theme ( gadget -- )
+: <bevel-button-paint> ( -- paint )
plain-gradient
rollover-gradient
pressed-gradient
selected-gradient
- <button-paint> over set-gadget-interior
- faint-boundary ;
+ <button-paint> ;
+
+: bevel-button-theme ( gadget -- gadget )
+ <bevel-button-paint> >>interior
+ faint-boundary ; inline
: <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
- <button> dup bevel-button-theme ;
+ <button> bevel-button-theme ;
TUPLE: repeat-button ;
diff --git a/extra/ui/gadgets/canvas/canvas.factor b/extra/ui/gadgets/canvas/canvas.factor
index 15df44fda4..0a9f07ed6e 100644
--- a/extra/ui/gadgets/canvas/canvas.factor
+++ b/extra/ui/gadgets/canvas/canvas.factor
@@ -9,7 +9,7 @@ TUPLE: canvas dlist ;
: <canvas> ( -- canvas )
canvas construct-gadget
- dup black solid-interior ;
+ black solid-interior ;
: delete-canvas-dlist ( canvas -- )
dup find-gl-context
diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor
index 63ab2f1d6f..3013dcd0bd 100755
--- a/extra/ui/gadgets/labelled/labelled.factor
+++ b/extra/ui/gadgets/labelled/labelled.factor
@@ -13,7 +13,7 @@ TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new
[
- <label> dup reverse-video-theme f track,
+ <label> reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
] { 0 1 } build-track ;
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index 167aa26084..f800b12120 100755
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/extra/ui/gadgets/labels/labels.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math namespaces
+USING: accessors arrays hashtables io kernel math namespaces
opengl sequences strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
@@ -10,7 +10,7 @@ IN: ui.gadgets.labels
TUPLE: label text font color ;
: label-string ( label -- string )
- label-text dup string? [ "\n" join ] unless ; inline
+ text>> dup string? [ "\n" join ] unless ; inline
: set-label-string ( string label -- )
CHAR: \n pick memq? [
@@ -19,21 +19,21 @@ TUPLE: label text font color ;
set-label-text
] if ; inline
-: label-theme ( gadget -- )
- black over set-label-color
- sans-serif-font swap set-label-font ;
+: label-theme ( gadget -- gadget )
+ sans-serif-font >>font
+ black >>color ; inline
: <label> ( string -- label )
label construct-gadget
[ set-label-string ] keep
- dup label-theme ;
+ label-theme ;
M: label pref-dim*
- dup label-font open-font swap label-text text-dim ;
+ [ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- dup label-color gl-color
- dup label-font swap label-text origin get draw-text ;
+ [ color>> gl-color ]
+ [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ;
@@ -45,12 +45,12 @@ M: label-control model-changed
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;
-: text-theme ( gadget -- )
- black over set-label-color
- monospace-font swap set-label-font ;
+: text-theme ( gadget -- gadget )
+ black >>color
+ monospace-font >>font ;
-: reverse-video-theme ( label -- )
- white over set-label-color
+: reverse-video-theme ( label -- label )
+ white >>color
black solid-interior ;
GENERIC: >label ( obj -- gadget )
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index fd5234ab03..43c0539e91 100755
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.commands ui.gestures ui.render ui.gadgets
+USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
@@ -27,17 +27,18 @@ TUPLE: list index presenter color hook ;
swap set-list-index ;
: list-presentation-hook ( list -- quot )
- list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
+ hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
- [ set-presentation-hook ] keep
- [ text-theme ] keep ;
+ swap >>hook
+ text-theme ; inline
: <list-items> ( list -- seq )
- dup list-presentation-hook
- over list-presenter
- rot control-value [
+ [ list-presentation-hook ]
+ [ presenter>> ]
+ [ control-value ]
+ tri [
>r 2dup r> swap <list-presentation>
] map 2nip ;
diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor
index 34051eaac0..153b4aeb6e 100644
--- a/extra/ui/gadgets/menus/menus.factor
+++ b/extra/ui/gadgets/menus/menus.factor
@@ -42,11 +42,11 @@ M: menu-glass layout* gadget-child prefer ;
[ hand-clicked get find-world hide-glass ]
3append <roll-button> ;
-: menu-theme ( gadget -- )
- dup light-gray solid-interior
+: menu-theme ( gadget -- gadget )
+ light-gray solid-interior
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
[
[ >r 2dup r> <menu-item> gadget, ] each 2drop
- ] make-filled-pile 5 <border> dup menu-theme ;
+ ] make-filled-pile 5 <border> menu-theme ;
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 880fb4450e..86d95e8ad0 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -182,7 +182,7 @@ M: pane-stream make-span-stream
foreground [ over set-label-color ] apply-style ;
: apply-background-style ( style gadget -- style gadget )
- background [ dupd solid-interior ] apply-style ;
+ background [ solid-interior ] apply-style ;
: specified-font ( style -- font )
[ font swap at "monospace" or ] keep
@@ -207,15 +207,15 @@ M: pane-stream make-span-stream
: apply-wrap-style ( style pane -- style pane )
wrap-margin [
- 2dup <paragraph> swap set-pane-prototype
- <paragraph> over set-pane-current
+ 2dup <paragraph> >>prototype drop
+ <paragraph> >>current
] apply-style ;
: apply-border-color-style ( style gadget -- style gadget )
- border-color [ dupd solid-boundary ] apply-style ;
+ border-color [ solid-boundary ] apply-style ;
: apply-page-color-style ( style gadget -- style gadget )
- page-color [ dupd solid-interior ] apply-style ;
+ page-color [ solid-interior ] apply-style ;
: apply-path-style ( style gadget -- style gadget )
presented-path [ <editable-slot> ] apply-style ;
@@ -224,9 +224,7 @@ M: pane-stream make-span-stream
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
- presented-printer [
- [ make-pane ] curry over set-editable-slot-printer
- ] apply-style ;
+ presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
@@ -294,11 +292,8 @@ M: pack dispose drop ;
M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
- over empty? [
- 2drop
- ] [
- >r <label> dup text-theme r> add-gadget
- ] if ;
+ over empty?
+ [ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
M: pack stream-write gadget-write ;
@@ -372,11 +367,11 @@ M: f sloppy-pick-up*
: extend-selection ( pane -- )
hand-moved? [
- dup pane-selecting? [
+ dup selecting?>> [
dup move-caret
] [
dup hand-clicked get child? [
- t over set-pane-selecting?
+ t >>selecting?
dup hand-clicked set-global
dup move-caret
dup caret>mark
@@ -386,10 +381,9 @@ M: f sloppy-pick-up*
] when drop ;
: end-selection ( pane -- )
- f over set-pane-selecting?
+ f >>selecting?
hand-moved? [
- dup com-copy-selection
- request-focus
+ [ com-copy-selection ] [ request-focus ] bi
] [
relayout-1
] if ;
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index e513853d27..e58fbc5925 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -46,7 +46,7 @@ scroller H{
y-model <y-slider> g-> set-scroller-y @right frame,
viewport,
] with-gadget
- ] keep t over set-gadget-root? dup faint-boundary ;
+ ] keep t >>root? faint-boundary ;
: scroll ( value scroller -- )
[
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor
index c781a9167d..eb22a5a823 100755
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
+USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models math.vectors math.functions quotations colors ;
@@ -65,14 +65,15 @@ thumb H{
{ T{ drag } [ do-drag ] }
} set-gestures
-: thumb-theme ( thumb -- )
- plain-gradient over set-gadget-interior faint-boundary ;
+: thumb-theme ( thumb -- thumb )
+ plain-gradient >>interior
+ faint-boundary ; inline
: <thumb> ( vector -- thumb )
thumb construct-gadget
- t over set-gadget-root?
- dup thumb-theme
- [ set-gadget-orientation ] keep ;
+ swap >>orientation
+ t >>root?
+ thumb-theme ;
: slide-by ( amount slider -- )
gadget-model move-by ;
diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor
index b528d6739c..417826a680 100755
--- a/extra/ui/gadgets/status-bar/status-bar.factor
+++ b/extra/ui/gadgets/status-bar/status-bar.factor
@@ -1,14 +1,14 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: models sequences ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
-calendar ;
+USING: accessors models sequences ui.gadgets.labels
+ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
+ui kernel calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <filter> <label-control>
- dup reverse-video-theme
- t over set-gadget-root? ;
+ reverse-video-theme
+ t >>root? ;
: open-status-window ( gadget title -- )
>r [
diff --git a/extra/ui/gadgets/theme/theme.factor b/extra/ui/gadgets/theme/theme.factor
index f0884f9486..68bd3b201a 100644
--- a/extra/ui/gadgets/theme/theme.factor
+++ b/extra/ui/gadgets/theme/theme.factor
@@ -2,17 +2,17 @@
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors ;
+colors accessors ;
IN: ui.gadgets.theme
-: solid-interior ( gadget color -- )
- <solid> swap set-gadget-interior ;
+: solid-interior ( gadget color -- gadget )
+ <solid> >>interior ; inline
-: solid-boundary ( gadget color -- )
- <solid> swap set-gadget-boundary ;
+: solid-boundary ( gadget color -- gadget )
+ <solid> >>boundary ; inline
-: faint-boundary ( gadget -- )
- gray solid-boundary ;
+: faint-boundary ( gadget -- gadget )
+ gray solid-boundary ; inline
: selection-color ( -- color ) light-purple ;
From 9a89a97c5a4314c39d86e1fff6ddca19759eb362 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 18 Jun 2008 23:29:56 -0500
Subject: [PATCH 37/85] Fix deploy tests for real
---
extra/io/encodings/8-bit/8-bit.factor | 52 ++++++++++++-------------
extra/tools/deploy/shaker/shaker.factor | 1 +
extra/tools/deploy/test/4/4.factor | 2 +-
3 files changed, 27 insertions(+), 28 deletions(-)
diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor
index 71c57ef68c..30eb745314 100755
--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@@ -30,15 +30,12 @@ IN: io.encodings.8-bit
} ;
: encoding-file ( file-name -- stream )
- "resource:extra/io/encodings/8-bit/" ".TXT"
- swapd 3append ascii <file-reader> ;
-
-: tail-if ( seq n -- newseq )
- 2dup swap length <= [ tail ] [ drop ] if ;
+ "resource:extra/io/encodings/8-bit/" swap ".TXT"
+ 3append ascii <file-reader> ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map harvest
- [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
+ [ "\t" split 2 head [ 2 short tail hex> ] map ] map ;
: byte>ch ( assoc -- array )
256 replacement-char <array>
@@ -51,39 +48,40 @@ IN: io.encodings.8-bit
lines process-contents
[ byte>ch ] [ ch>byte ] bi ;
-TUPLE: 8-bit name decode encode ;
+SYMBOL: 8-bit-encodings
+
+TUPLE: 8-bit decode encode ;
: encode-8-bit ( char stream assoc -- )
- swapd at* [ encode-error ] unless swap stream-write1 ;
+ swap >r at*
+ [ r> stream-write1 ] [ r> drop encode-error ] if ; inline
-M: 8-bit encode-char
- encode>> encode-8-bit ;
+M: 8-bit encode-char encode>> encode-8-bit ;
: decode-8-bit ( stream array -- char/f )
- swap stream-read1 dup
- [ swap nth [ replacement-char ] unless* ]
- [ nip ] if ;
+ >r stream-read1 dup
+ [ r> nth [ replacement-char ] unless* ] [ r> 2drop f ] if ; inline
-M: 8-bit decode-char
- decode>> decode-8-bit ;
-
-: make-8-bit ( word byte>ch ch>byte -- )
- [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ;
-
-: define-8-bit-encoding ( name stream -- )
- >r in get create r> parse-file make-8-bit ;
+M: 8-bit decode-char decode>> decode-8-bit ;
PREDICATE: 8-bit-encoding < word
- word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ;
+ 8-bit-encodings get-global key? ;
-M: 8-bit-encoding <encoder> word-def first <encoder> ;
+M: 8-bit-encoding <encoder>
+ 8-bit-encodings get-global at <encoder> ;
-M: 8-bit-encoding <decoder> word-def first <decoder> ;
+M: 8-bit-encoding <decoder>
+ 8-bit-encodings get-global at <decoder> ;
PRIVATE>
[
- "io.encodings.8-bit" in [
- mappings [ encoding-file define-8-bit-encoding ] assoc-each
- ] with-variable
+ mappings [
+ [ "io.encodings.8-bit" create ]
+ [ encoding-file parse-file 8-bit boa ]
+ bi*
+ ] assoc-map
+ [ 8-bit-encodings set-global ]
+ [ [ [ ] curry define ] assoc-each ]
+ bi
] with-compilation-unit
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index db0f478709..3df5485f4e 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -66,6 +66,7 @@ IN: tools.deploy.shaker
: strip-word-defs ( words -- )
"Stripping symbolic word definitions" show
+ [ "no-def-strip" word-prop not ] filter
[ [ ] swap set-word-def ] each ;
: strip-word-props ( retain-props words -- )
diff --git a/extra/tools/deploy/test/4/4.factor b/extra/tools/deploy/test/4/4.factor
index 6831eae5d3..a9ee71131c 100644
--- a/extra/tools/deploy/test/4/4.factor
+++ b/extra/tools/deploy/test/4/4.factor
@@ -2,6 +2,6 @@ IN: tools.deploy.test.4
USING: io.encodings.8-bit io.encodings.string kernel ;
: deploy-test-4 ( -- )
- "xyzthg" latin7 encode drop ;
+ "xyzthg" \ latin7 encode drop ;
MAIN: deploy-test-4
From 001e866b13e8fbc65d6d704b2e9794fca8eb9dc6 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 11:49:08 +1200
Subject: [PATCH 38/85] Add yet another failing ebnf unit test
---
extra/peg/ebnf/ebnf-tests.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index ed38d37421..f613002fdf 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -442,3 +442,7 @@ foo=<foreign any-char> 'd'
{ V{ CHAR: a "d" } } [
"ad" parser4 ast>>
] unit-test
+
+{ V{ "a" "\n" } } [
+ "a\n" [EBNF foo='a' '\n' => [[ drop '\n' ]] EBNF] call ast>>
+] unit-test
\ No newline at end of file
From 91768f171c5bd8721d2a1c20a75478b9692857b0 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 11:53:07 +1200
Subject: [PATCH 39/85] Rule 'x' defined more than once unit test
---
extra/peg/ebnf/ebnf-tests.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index f613002fdf..1824c0342a 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -445,4 +445,8 @@ foo=<foreign any-char> 'd'
{ V{ "a" "\n" } } [
"a\n" [EBNF foo='a' '\n' => [[ drop '\n' ]] EBNF] call ast>>
+] unit-test
+
+{ t } [
+ [EBNF foo='a' foo='b' EBNF] drop t
] unit-test
\ No newline at end of file
From 6bd761e4609a1ac2048e7bde627c4ccc384adc4a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 12:35:33 +1200
Subject: [PATCH 40/85] Another breaking unit test for ebnf
---
extra/peg/ebnf/ebnf-tests.factor | 15 +++++++++++----
1 file changed, 11 insertions(+), 4 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 1824c0342a..0a16fc8007 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser
- sequences accessors peg.parsers ;
+ sequences accessors peg.parsers parser namespaces ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -443,10 +443,17 @@ foo=<foreign any-char> 'd'
"ad" parser4 ast>>
] unit-test
-{ V{ "a" "\n" } } [
- "a\n" [EBNF foo='a' '\n' => [[ drop '\n' ]] EBNF] call ast>>
+{ t } [
+ "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop '\n' ]] EBNF]" eval drop t
] unit-test
+[
+ "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval
+] must-fail
+
+
{ t } [
- [EBNF foo='a' foo='b' EBNF] drop t
+ #! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
+ #! if a var in a namespace is set. This unit test is to remind me to fix this.
+ [ "fail" "foo" set "foo='a'" 'ebnf' parse ast>> transform drop t ] with-scope
] unit-test
\ No newline at end of file
From d22a24a90eef38975b6eb5bacfc010477730d453 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 14:13:50 +1200
Subject: [PATCH 41/85] Fix some failing ebnf unit tests
---
extra/peg/ebnf/ebnf-tests.factor | 2 +-
extra/peg/ebnf/ebnf.factor | 31 +++++++++++++++++++------------
2 files changed, 20 insertions(+), 13 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 0a16fc8007..e3c6586c89 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -444,7 +444,7 @@ foo=<foreign any-char> 'd'
] unit-test
{ t } [
- "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop '\n' ]] EBNF]" eval drop t
+ "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
] unit-test
[
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e78757be34..cba48f5892 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -63,6 +63,20 @@ C: <ebnf> ebnf
#! begin and end.
[ syntax ] 2dip syntax pack ;
+: replace-escapes ( string -- string )
+ [
+ "\\t" token [ drop "\t" ] action ,
+ "\\n" token [ drop "\n" ] action ,
+ "\\r" token [ drop "\r" ] action ,
+ ] choice* replace ;
+
+: insert-escapes ( string -- string )
+ [
+ "\t" token [ drop "\\t" ] action ,
+ "\n" token [ drop "\\n" ] action ,
+ "\r" token [ drop "\\r" ] action ,
+ ] choice* replace ;
+
: 'identifier' ( -- parser )
#! Return a parser that parses an identifer delimited by
#! a quotation character. The quotation can be single
@@ -71,7 +85,7 @@ C: <ebnf> ebnf
[
[ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
[ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
- ] choice* [ >string ] action ;
+ ] choice* [ >string replace-escapes ] action ;
: 'non-terminal' ( -- parser )
#! A non-terminal is the name of another rule. It can
@@ -401,11 +415,11 @@ M: object build-locals ( code ast -- )
} cond ;
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
string-lines parse-lines check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
string-lines parse-lines semantic ;
M: ebnf-var (transform) ( ast -- parser )
@@ -453,17 +467,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ] curry ;
-: replace-escapes ( string -- string )
- [
- "\\t" token [ drop "\t" ] action ,
- "\\n" token [ drop "\n" ] action ,
- "\\r" token [ drop "\r" ] action ,
- ] choice* replace ;
-
-: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing
+: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
- ";EBNF" parse-multiline-string replace-escapes
+ ";EBNF" parse-multiline-string
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
From 7239c4d79f590997ddfa25ce3e6423c568b5cb62 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 15:14:30 +1200
Subject: [PATCH 42/85] Make replace-escapes infer and fix remaining unit test
breakage in ebnf
---
extra/peg/ebnf/ebnf-tests.factor | 2 +-
extra/peg/ebnf/ebnf.factor | 15 ++++++++++++---
2 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index e3c6586c89..5a4ecc5c2f 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -448,7 +448,7 @@ foo=<foreign any-char> 'd'
] unit-test
[
- "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval
+ "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval drop
] must-fail
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index cba48f5892..8f36218b61 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -63,12 +63,17 @@ C: <ebnf> ebnf
#! begin and end.
[ syntax ] 2dip syntax pack ;
-: replace-escapes ( string -- string )
+#! Don't want to use 'replace' in an action since replace doesn't infer.
+#! Do the compilation of the peg at parse time and call (replace).
+PEG: escaper ( string -- ast )
[
"\\t" token [ drop "\t" ] action ,
"\\n" token [ drop "\n" ] action ,
"\\r" token [ drop "\r" ] action ,
- ] choice* replace ;
+ ] choice* any-char-parser 2array choice repeat0 ;
+
+: replace-escapes ( string -- string )
+ escaper sift [ [ tree-write ] each ] with-string-writer ;
: insert-escapes ( string -- string )
[
@@ -319,7 +324,11 @@ M: ebnf (transform) ( ast -- parser )
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
- swap symbol>> dup get [ "Rule '" over append "' defined more than once" append throw ] [ set ] if
+ swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [
+ "Rule '" over append "' defined more than once" append throw
+ ] [
+ set
+ ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
From b6b5f12732914b36a0939f1f0221eaf29f9867d0 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 20 Jun 2008 22:29:53 +1200
Subject: [PATCH 43/85] Provide ability to plug in tokenizers to ebnf parsers
---
extra/peg/ebnf/ebnf.factor | 49 ++++++++++++++++---
.../peg/javascript/tokenizer/tokenizer.factor | 2 +-
2 files changed, 44 insertions(+), 7 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 8f36218b61..921ba7be67 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -11,6 +11,31 @@ IN: peg.ebnf
#! Given an EBNF word produced from EBNF: return the EBNF rule
"ebnf-parser" word-prop at ;
+TUPLE: tokenizer any one many ;
+
+: default-tokenizer ( -- tokenizer )
+ T{ tokenizer f
+ [ [ drop t ] satisfy ]
+ [ token ]
+ [ [ = ] curry satisfy ]
+ } ;
+
+: parser-tokenizer ( parser -- tokenizer )
+ 1quotation [ [ = ] curry satisfy ] dup tokenizer boa ;
+
+: rule-tokenizer ( name word -- tokenizer )
+ rule parser-tokenizer ;
+
+: tokenizer ( -- word )
+ \ tokenizer get [ default-tokenizer ] unless* ;
+
+: reset-tokenizer ( -- )
+ default-tokenizer \ tokenizer set-global ;
+
+: TOKENIZER:
+ scan search [ "Tokenizer not found" throw ] unless*
+ execute \ tokenizer set-global ; parsing
+
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-foreign word rule ;
@@ -344,7 +369,7 @@ M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
M: ebnf-any-character (transform) ( ast -- parser )
- drop any-char ;
+ drop [ tokenizer any>> call ] box ;
M: ebnf-range (transform) ( ast -- parser )
pattern>> range-pattern ;
@@ -435,7 +460,7 @@ M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
- symbol>> [ token ] keep [ = ] curry satisfy 2choice ;
+ symbol>> [ tokenizer one>> call ] curry box ;
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
@@ -476,10 +501,22 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ] curry ;
-: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
+: [EBNF
+ scan {
+ { "+" [ scan-word execute "" swap ] }
+ [ " " append default-tokenizer ]
+ } case \ tokenizer [
+ [ "EBNF]" parse-multiline-string ] [ drop "" ] recover append ebnf>quot nip parsed
+ ] with-variable ; parsing
: EBNF:
- CREATE-WORD dup
- ";EBNF" parse-multiline-string
- ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
+ CREATE-WORD scan {
+ { "+" [ scan-word execute "" swap ] }
+ [ " " append default-tokenizer ]
+ } case \ tokenizer [
+ dupd [ ";EBNF" parse-multiline-string ] [ drop "" ] recover append
+ ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop
+ ] with-variable ; parsing
+
+
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index a1cff8a3db..5bf6a639fa 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -8,7 +8,7 @@ IN: peg.javascript.tokenizer
USE: prettyprint
-EBNF: tokenizer
+EBNF: javascript-tokenizer
Letter = [a-zA-Z]
Digit = [0-9]
Digits = Digit+
From eca8260799dde2a4da0df6ac78e83356ad34f3df Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 00:28:13 +1200
Subject: [PATCH 44/85] peg.ebnf syntax for tokenizers
---
extra/peg/ebnf/ebnf-tests.factor | 59 ++++++++++++++++++++++++++++++--
extra/peg/ebnf/ebnf.factor | 41 ++++++++++++++++------
2 files changed, 87 insertions(+), 13 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 5a4ecc5c2f..a90fa98436 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser
- sequences accessors peg.parsers parser namespaces ;
+ sequences accessors peg.parsers parser namespaces arrays
+ strings ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -451,9 +452,63 @@ foo=<foreign any-char> 'd'
"USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval drop
] must-fail
-
{ t } [
#! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
#! if a var in a namespace is set. This unit test is to remind me to fix this.
[ "fail" "foo" set "foo='a'" 'ebnf' parse ast>> transform drop t ] with-scope
+] unit-test
+
+#! Tokenizer tests
+{ V{ "a" CHAR: b } } [
+ "ab" [EBNF tokenizer=default foo="a" . EBNF] call ast>>
+] unit-test
+
+TUPLE: ast-number value ;
+
+EBNF: a-tokenizer
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = Digit+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
+Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
+Spaces = Space* => [[ ignore ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Number | Special )
+;EBNF
+
+{ V{ CHAR: 1 T{ ast-number f 23 } ";" CHAR: x } } [
+ "123;x" [EBNF bar = .
+ tokenizer = <foreign a-tokenizer Tok> foo=.
+ tokenizer=default baz=.
+ main = bar foo foo baz
+ EBNF] call ast>>
+] unit-test
+
+{ V{ CHAR: 5 "+" CHAR: 2 } } [
+ "5+2" [EBNF
+ space=(" " | "\n")
+ number=[0-9]
+ operator=("*" | "+")
+ spaces=space* => [[ ignore ]]
+ tokenizer=spaces (number | operator)
+ main= . . .
+ EBNF] call ast>>
+] unit-test
+
+{ V{ CHAR: 5 "+" CHAR: 2 } } [
+ "5 + 2" [EBNF
+ space=(" " | "\n")
+ number=[0-9]
+ operator=("*" | "+")
+ spaces=space* => [[ ignore ]]
+ tokenizer=spaces (number | operator)
+ main= . . .
+ EBNF] call ast>>
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 921ba7be67..25889fe44d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -27,7 +27,7 @@ TUPLE: tokenizer any one many ;
rule parser-tokenizer ;
: tokenizer ( -- word )
- \ tokenizer get [ default-tokenizer ] unless* ;
+ \ tokenizer get-global [ default-tokenizer ] unless* ;
: reset-tokenizer ( -- )
default-tokenizer \ tokenizer set-global ;
@@ -49,6 +49,7 @@ TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional group ;
TUPLE: ebnf-whitespace group ;
+TUPLE: ebnf-tokenizer elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ;
TUPLE: ebnf-var parser name ;
@@ -68,6 +69,7 @@ C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-repeat1> ebnf-repeat1
C: <ebnf-optional> ebnf-optional
C: <ebnf-whitespace> ebnf-whitespace
+C: <ebnf-tokenizer> ebnf-tokenizer
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf-var> ebnf-var
@@ -318,8 +320,17 @@ DEFER: 'choice'
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
+: 'tokenizer' ( -- parser )
+ [
+ "tokenizer" syntax ,
+ "=" syntax ,
+ ">" token ensure-not ,
+ [ "default" token sp , 'choice' , ] choice* ,
+ ] seq* [ first <ebnf-tokenizer> ] action ;
+
: 'rule' ( -- parser )
[
+ "tokenizer" token ensure-not ,
'non-terminal' [ symbol>> ] action ,
"=" syntax ,
">" token ensure-not ,
@@ -327,7 +338,7 @@ DEFER: 'choice'
] seq* [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
- 'rule' sp repeat1 [ <ebnf> ] action ;
+ [ 'tokenizer' sp , 'rule' sp , ] choice* repeat1 [ <ebnf> ] action ;
GENERIC: (transform) ( ast -- parser )
@@ -345,6 +356,14 @@ SYMBOL: ignore-ws
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
+
+M: ebnf-tokenizer (transform) ( ast -- parser )
+ elements>> dup "default" = [
+ drop default-tokenizer \ tokenizer set-global any-char
+ ] [
+ (transform)
+ dup parser-tokenizer \ tokenizer set-global
+ ] if ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
@@ -369,7 +388,7 @@ M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
M: ebnf-any-character (transform) ( ast -- parser )
- drop [ tokenizer any>> call ] box ;
+ drop tokenizer any>> call ;
M: ebnf-range (transform) ( ast -- parser )
pattern>> range-pattern ;
@@ -460,7 +479,7 @@ M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
- symbol>> [ tokenizer one>> call ] curry box ;
+ symbol>> tokenizer one>> call ;
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
@@ -505,18 +524,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
scan {
{ "+" [ scan-word execute "" swap ] }
[ " " append default-tokenizer ]
- } case \ tokenizer [
- [ "EBNF]" parse-multiline-string ] [ drop "" ] recover append ebnf>quot nip parsed
- ] with-variable ; parsing
+ } case \ tokenizer set-global
+ [ "EBNF]" parse-multiline-string ] [ drop "" ] recover append ebnf>quot nip parsed
+ reset-tokenizer ; parsing
: EBNF:
CREATE-WORD scan {
{ "+" [ scan-word execute "" swap ] }
[ " " append default-tokenizer ]
- } case \ tokenizer [
- dupd [ ";EBNF" parse-multiline-string ] [ drop "" ] recover append
- ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop
- ] with-variable ; parsing
+ } case \ tokenizer set-global
+ dupd [ ";EBNF" parse-multiline-string ] [ drop "" ] recover append
+ ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop
+ reset-tokenizer ; parsing
From 5433553571fd0c2382cb334fc94336515faa5c7d Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 01:00:27 +1200
Subject: [PATCH 45/85] Remove EBNF: and [EBNF EBNF] +tokenizer syntax replaced
with tokenizer support in ebnf grammar itself.
---
extra/peg/ebnf/ebnf.factor | 14 ++------------
extra/peg/javascript/javascript.factor | 4 ++--
extra/peg/javascript/parser/parser-tests.factor | 10 +++++-----
extra/peg/javascript/parser/parser.factor | 2 +-
.../javascript/tokenizer/tokenizer-tests.factor | 4 ++--
extra/peg/javascript/tokenizer/tokenizer.factor | 2 +-
6 files changed, 13 insertions(+), 23 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 25889fe44d..564b376b29 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -520,20 +520,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ] curry ;
-: [EBNF
- scan {
- { "+" [ scan-word execute "" swap ] }
- [ " " append default-tokenizer ]
- } case \ tokenizer set-global
- [ "EBNF]" parse-multiline-string ] [ drop "" ] recover append ebnf>quot nip parsed
- reset-tokenizer ; parsing
+: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip parsed reset-tokenizer ; parsing
: EBNF:
- CREATE-WORD scan {
- { "+" [ scan-word execute "" swap ] }
- [ " " append default-tokenizer ]
- } case \ tokenizer set-global
- dupd [ ";EBNF" parse-multiline-string ] [ drop "" ] recover append
+ reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop
reset-tokenizer ; parsing
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 23a4b4f7f0..d27a06e9d2 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -4,8 +4,8 @@ USING: kernel accessors peg.javascript.tokenizer peg.javascript.parser ;
IN: peg.javascript
: parse-javascript ( string -- ast )
- tokenizer [
- ast>> javascript [
+ tokenize-javascript [
+ ast>> parse-javascript [
ast>>
] [
"Unable to parse JavaScript" throw
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index d911a27285..b19bb314bb 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -5,7 +5,7 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer
peg.javascript.parser accessors multiline sequences math ;
IN: peg.javascript.parser.tests
-\ javascript must-infer
+\ parse-javascript must-infer
{
T{
@@ -23,14 +23,14 @@ IN: peg.javascript.parser.tests
}
}
} [
- "123; 'hello'; foo(x);" tokenizer ast>> javascript ast>>
+ "123; 'hello'; foo(x);" tokenize-javascript ast>> parse-javascript ast>>
] unit-test
{ t } [
<"
var x=5
var y=10
-"> tokenizer ast>> javascript remaining>> length zero?
+"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
] unit-test
@@ -41,7 +41,7 @@ function foldl(f, initial, seq) {
initial = f(initial, seq[i]);
return initial;
}
-"> tokenizer ast>> javascript remaining>> length zero?
+"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
] unit-test
{ t } [
@@ -52,6 +52,6 @@ ParseState.prototype.from = function(index) {
r.length = this.length - index;
return r;
}
-"> tokenizer ast>> javascript remaining>> length zero?
+"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
] unit-test
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 45aa0f022c..1a074090f3 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -6,7 +6,7 @@ IN: peg.javascript.parser
#! Grammar for JavaScript. Based on OMeta-JS example from:
#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
-EBNF: javascript
+EBNF: parse-javascript
End = !(.)
Space = " " | "\t" | "\n"
Spaces = Space* => [[ ignore ]]
diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
index 1300b3c9c7..509ff4a0fe 100644
--- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
@@ -4,7 +4,7 @@
USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
IN: peg.javascript.tokenizer.tests
-\ tokenizer must-infer
+\ tokenize-javascript must-infer
{
V{
@@ -19,5 +19,5 @@ IN: peg.javascript.tokenizer.tests
";"
}
} [
- "123; 'hello'; foo(x);" tokenizer ast>>
+ "123; 'hello'; foo(x);" tokenize-javascript ast>>
] unit-test
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index 5bf6a639fa..b72173f956 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -8,7 +8,7 @@ IN: peg.javascript.tokenizer
USE: prettyprint
-EBNF: javascript-tokenizer
+EBNF: tokenize-javascript
Letter = [a-zA-Z]
Digit = [0-9]
Digits = Digit+
From 6b83ab9d9060f8972b43d7082253a3a957d1f96f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 01:49:07 +1200
Subject: [PATCH 46/85] Fix terminal parser with non-default tokenizers
---
extra/peg/ebnf/ebnf-tests.factor | 4 ++++
extra/peg/ebnf/ebnf.factor | 7 ++++---
extra/peg/javascript/javascript.factor | 2 +-
extra/peg/javascript/parser/parser-tests.factor | 14 +++++++-------
extra/peg/javascript/parser/parser.factor | 5 +++--
5 files changed, 19 insertions(+), 13 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index a90fa98436..2269af6625 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -511,4 +511,8 @@ Tok = Spaces (Number | Special )
tokenizer=spaces (number | operator)
main= . . .
EBNF] call ast>>
+] unit-test
+
+{ "++" } [
+ "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] call ast>>
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 564b376b29..4725534178 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -15,13 +15,14 @@ TUPLE: tokenizer any one many ;
: default-tokenizer ( -- tokenizer )
T{ tokenizer f
- [ [ drop t ] satisfy ]
+ [ any-char ]
[ token ]
- [ [ = ] curry satisfy ]
+ [ [ = ] curry any-char swap semantic ]
} ;
: parser-tokenizer ( parser -- tokenizer )
- 1quotation [ [ = ] curry satisfy ] dup tokenizer boa ;
+ [ 1quotation ] keep
+ [ swap [ = ] curry semantic ] curry dup tokenizer boa ;
: rule-tokenizer ( name word -- tokenizer )
rule parser-tokenizer ;
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index d27a06e9d2..791f63c56b 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -5,7 +5,7 @@ IN: peg.javascript
: parse-javascript ( string -- ast )
tokenize-javascript [
- ast>> parse-javascript [
+ ast>> javascript [
ast>>
] [
"Unable to parse JavaScript" throw
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index b19bb314bb..fd0e27b6d4 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer
- peg.javascript.parser accessors multiline sequences math ;
+USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
+ accessors multiline sequences math ;
IN: peg.javascript.parser.tests
-\ parse-javascript must-infer
+\ javascript must-infer
{
T{
@@ -23,14 +23,14 @@ IN: peg.javascript.parser.tests
}
}
} [
- "123; 'hello'; foo(x);" tokenize-javascript ast>> parse-javascript ast>>
+ "123; 'hello'; foo(x);" javascript ast>>
] unit-test
{ t } [
<"
var x=5
var y=10
-"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
+"> javascript remaining>> length zero?
] unit-test
@@ -41,7 +41,7 @@ function foldl(f, initial, seq) {
initial = f(initial, seq[i]);
return initial;
}
-"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
+"> javascript remaining>> length zero?
] unit-test
{ t } [
@@ -52,6 +52,6 @@ ParseState.prototype.from = function(index) {
r.length = this.length - index;
return r;
}
-"> tokenize-javascript ast>> parse-javascript remaining>> length zero?
+"> javascript remaining>> length zero?
] unit-test
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 1a074090f3..0239ce882c 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -1,12 +1,13 @@
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors peg peg.ebnf peg.javascript.ast ;
+USING: kernel accessors peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ;
IN: peg.javascript.parser
#! Grammar for JavaScript. Based on OMeta-JS example from:
#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
-EBNF: parse-javascript
+EBNF: javascript
+tokenizer = <foreign tokenize-javascript Tok>
End = !(.)
Space = " " | "\t" | "\n"
Spaces = Space* => [[ ignore ]]
From ff8e52190725b8b3f1790c7909380a88b713eafb Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 02:06:58 +1200
Subject: [PATCH 47/85] Fix automatic semicolon insertion rule in JavaScript
parser
---
extra/peg/javascript/parser/parser.factor | 18 ++++++++++++++++--
1 file changed, 16 insertions(+), 2 deletions(-)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 0239ce882c..f9a070dd86 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -6,7 +6,21 @@ IN: peg.javascript.parser
#! Grammar for JavaScript. Based on OMeta-JS example from:
#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+#! The interesting thing about this parser is the mixing of
+#! a default and non-default tokenizer. The JavaScript tokenizer
+#! removes all newlines. So when operating on tokens there is no
+#! need for newline and space skipping in the grammar. But JavaScript
+#! uses the newline in the 'automatic semicolon insertion' rule.
+#!
+#! If a statement ends in a newline, sometimes the semicolon can be
+#! skipped. So we define an 'nl' rule using the default tokenizer.
+#! This operates a character at a time. Using this 'nl' in the parser
+#! allows us to detect newlines when we need to for the semicolon
+#! insertion rule, but ignore it in all other places.
EBNF: javascript
+tokenizer = default
+nl = "\n"
+
tokenizer = <foreign tokenize-javascript Tok>
End = !(.)
Space = " " | "\t" | "\n"
@@ -14,7 +28,7 @@ Spaces = Space* => [[ ignore ]]
Name = . ?[ ast-name? ]? => [[ value>> ]]
Number = . ?[ ast-number? ]? => [[ value>> ]]
String = . ?[ ast-string? ]? => [[ value>> ]]
-SpacesNoNl = (!("\n") Space)* => [[ ignore ]]
+SpacesNoNl = (!(nl) Space)* => [[ ignore ]]
Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
| OrExpr:e "=" Expr:rhs => [[ e rhs ast-set boa ]]
@@ -80,7 +94,7 @@ JsonPropName = Name | Number | String
Formal = Spaces Name
Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
-Sc = SpacesNoNl ("\n" | &("}") | End)| ";"
+Sc = SpacesNoNl (nl | &("}") | End)| ";"
Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
| Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
Block = "{" SrcElems:ss "}" => [[ ss ]]
From 4a47346bda1522f08a725a5c85f7516a0342c8b2 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 02:09:46 +1200
Subject: [PATCH 48/85] Fix parse-javascript word for recent changes
---
extra/peg/javascript/javascript.factor | 11 +++--------
1 file changed, 3 insertions(+), 8 deletions(-)
diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor
index 791f63c56b..8fe0538eae 100644
--- a/extra/peg/javascript/javascript.factor
+++ b/extra/peg/javascript/javascript.factor
@@ -4,13 +4,8 @@ USING: kernel accessors peg.javascript.tokenizer peg.javascript.parser ;
IN: peg.javascript
: parse-javascript ( string -- ast )
- tokenize-javascript [
- ast>> javascript [
- ast>>
- ] [
- "Unable to parse JavaScript" throw
- ] if*
+ javascript [
+ ast>>
] [
- "Unable to tokenize JavaScript" throw
+ "Unable to parse JavaScript" throw
] if* ;
-
From e8f990454905d86241f824ba29452ed82d3a0c02 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 02:21:54 +1200
Subject: [PATCH 49/85] Add \r to the JavaScript automatic semicolon insertion
routine
---
extra/peg/javascript/parser/parser.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index f9a070dd86..15ab8ee1c4 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -19,7 +19,7 @@ IN: peg.javascript.parser
#! insertion rule, but ignore it in all other places.
EBNF: javascript
tokenizer = default
-nl = "\n"
+nl = "\r" "\n" | "\n"
tokenizer = <foreign tokenize-javascript Tok>
End = !(.)
From 8fa0c80d4e93780d3a31623702fe721ea1c5e1d1 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 02:29:47 +1200
Subject: [PATCH 50/85] Add regular expressions to JavaScript parser
---
extra/peg/javascript/parser/parser.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 15ab8ee1c4..6abe2fb385 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -28,6 +28,7 @@ Spaces = Space* => [[ ignore ]]
Name = . ?[ ast-name? ]? => [[ value>> ]]
Number = . ?[ ast-number? ]? => [[ value>> ]]
String = . ?[ ast-string? ]? => [[ value>> ]]
+RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]
SpacesNoNl = (!(nl) Space)* => [[ ignore ]]
Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
@@ -83,6 +84,7 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| Name => [[ ast-get boa ]]
| Number => [[ ast-number boa ]]
| String => [[ ast-string boa ]]
+ | RegExp => [[ ast-regexp boa ]]
| "function" FuncRest:fr => [[ fr ]]
| "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
@@ -90,7 +92,7 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
-JsonPropName = Name | Number | String
+JsonPropName = Name | Number | String | RegExp
Formal = Spaces Name
Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
From c5a9ee0e160ca7fd087198bf50a750df7f8f2f81 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 02:40:08 +1200
Subject: [PATCH 51/85] Add typeof, void and delete to JavaScript grammar
---
extra/peg/javascript/parser/parser.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 6abe2fb385..5eb42daa31 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -69,6 +69,9 @@ Unary = "-" Postfix:p => [[ p "-" ast-unop boa
| "++" Postfix:p => [[ p "++" ast-preop boa ]]
| "--" Postfix:p => [[ p "--" ast-preop boa ]]
| "!" Postfix:p => [[ p "!" ast-unop boa ]]
+ | "typeof" Postfix:p => [[ p "typeof" ast-unop boa ]]
+ | "void" Postfix:p => [[ p "void" ast-unop boa ]]
+ | "delete" Postfix:p => [[ p "delete" ast-unop boa ]]
| Postfix
Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
| PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
From a15783cabb4250bcab5376e6b2869e3aff270fbe Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 10:32:15 +1200
Subject: [PATCH 52/85] Fix typo in != in JavaScript parser
---
extra/peg/javascript/tokenizer/tokenizer.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index b72173f956..195184a16c 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -60,7 +60,7 @@ Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]]
RegExp = "/" RegExpBody:r "/" => [[ r ast-regexp boa ]]
Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
- | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">="
| ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
| "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
| "&&" | "||=" | "||" | "." | "!"
From fa2cd6a709cbf793b83e805b58d00318e92d0d3a Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Fri, 20 Jun 2008 22:52:44 -0400
Subject: [PATCH 53/85] Added extra/graph-theory
---
extra/graph-theory/graph-theory-docs.factor | 135 ++++++++++++++++++
extra/graph-theory/graph-theory.factor | 92 ++++++++++++
extra/graph-theory/reversals/reversals.factor | 22 +++
extra/graph-theory/sparse/sparse.factor | 35 +++++
4 files changed, 284 insertions(+)
create mode 100644 extra/graph-theory/graph-theory-docs.factor
create mode 100644 extra/graph-theory/graph-theory.factor
create mode 100644 extra/graph-theory/reversals/reversals.factor
create mode 100644 extra/graph-theory/sparse/sparse.factor
diff --git a/extra/graph-theory/graph-theory-docs.factor b/extra/graph-theory/graph-theory-docs.factor
new file mode 100644
index 0000000000..82d8b9adf6
--- /dev/null
+++ b/extra/graph-theory/graph-theory-docs.factor
@@ -0,0 +1,135 @@
+! See http://factorcode.org/license.txt for BSD licence.
+USING: help.markup help.syntax ;
+
+IN: graph-theory
+
+ARTICLE: "graph-protocol" "Graph protocol"
+"All graphs must be instances of the graph mixin:"
+{ $subsection graph }
+"All graphs must implement a method on the following generic word:"
+{ $subsection vertices }
+"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
+{ $subsection adjlist }
+{ $subsection adj? }
+"All mutable graphs must implement a method on the following generic word:"
+{ $subsection add-blank-vertex }
+"All mutable undirected graphs must implement a method on the following generic word:"
+{ $subsection add-edge }
+"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
+{ $subsection add-edge* }
+"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
+{ $subsection num-vertices }
+{ $subsection num-edges } ;
+
+HELP: graph
+{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
+ { $code "INSTANCE: hex-board graph" }
+} ;
+
+{ vertices num-vertices num-edges } related-words
+
+HELP: vertices
+{ $values { "graph" graph } { "seq" "The vertices" } }
+{ $description "Returns the vertices of the graph." } ;
+
+HELP: num-vertices
+{ $values { "graph" graph } { "n" "The number of vertices" } }
+{ $description "Returns the number of vertices in the graph." } ;
+
+HELP: num-edges
+{ $values { "graph" "A graph" } { "n" "The number of edges" } }
+{ $description "Returns the number of edges in the graph." } ;
+
+{ adjlist adj? } related-words
+
+HELP: adjlist
+{ $values
+ { "from" "The index of a vertex" }
+ { "graph" "The graph to be examined" }
+ { "seq" "The adjacency list" } }
+{ $description "Returns a sequence of vertices that this vertex links to" } ;
+
+HELP: adj?
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of a vertex" }
+ { "graph" "A graph" }
+ { "?" "A boolean" } }
+{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
+
+{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
+
+HELP: add-blank-vertex
+{ $values
+ { "index" "A vertex index" }
+ { "graph" "A graph" } }
+{ $description "Adds a vertex to the graph." } ;
+
+HELP: add-blank-vertices
+{ $values
+ { "seq" "A sequence of vertex indices" }
+ { "graph" "A graph" } }
+{ $description "Adds vertices with indices in seq to the graph." } ;
+
+HELP: add-edge*
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a one-way edge to the graph, between from and to."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "m" "The index of a vertex" }
+ { "n" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between m and n."
+ $nl
+ "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
+
+{ depth-first full-depth-first dag? topological-sort } related-words
+
+HELP: depth-first
+{ $values
+ { "v" "The vertex to start the search at" }
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "?list" "A list of booleans describing the vertices visited in the search" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
+
+HELP: full-depth-first
+{ $values
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "tail" "A quotation of the form ( -- )" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
+
+HELP: dag?
+{ $values
+ { "graph" graph }
+ { "?" "A boolean indicating if the graph is acyclic" } }
+{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
+
+HELP: topological-sort
+{ $values
+ { "graph" graph }
+ { "seq/f" "Either a sequence of values or f" } }
+{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
diff --git a/extra/graph-theory/graph-theory.factor b/extra/graph-theory/graph-theory.factor
new file mode 100644
index 0000000000..322f17d2dd
--- /dev/null
+++ b/extra/graph-theory/graph-theory.factor
@@ -0,0 +1,92 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
+
+IN: graph-theory
+
+MIXIN: graph
+SYMBOL: visited?
+ERROR: end-search ;
+
+GENERIC: vertices ( graph -- seq ) flushable
+
+GENERIC: num-vertices ( graph -- n ) flushable
+
+GENERIC: num-edges ( graph -- n ) flushable
+
+GENERIC: adjlist ( from graph -- seq ) flushable
+
+GENERIC: adj? ( from to graph -- ? ) flushable
+
+GENERIC: add-blank-vertex ( index graph -- )
+
+GENERIC: delete-blank-vertex ( index graph -- )
+
+GENERIC: add-edge* ( from to graph -- )
+
+GENERIC: add-edge ( u v graph -- )
+
+GENERIC: delete-edge* ( from to graph -- )
+
+GENERIC: delete-edge ( u v graph -- )
+
+M: graph num-vertices
+ vertices length ;
+
+M: graph num-edges
+ [ vertices ] [ '[ , adjlist length ] map sum ] bi ;
+
+M: graph adjlist
+ [ vertices ] [ swapd '[ , swap , adj? ] filter ] bi ;
+
+M: graph adj?
+ swapd adjlist index >boolean ;
+
+M: graph add-edge
+ [ add-edge* ] [ swapd add-edge* ] 3bi ;
+
+M: graph delete-edge
+ [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
+
+: add-blank-vertices ( seq graph -- )
+ '[ , add-blank-vertex ] each ;
+
+: delete-vertex ( index graph -- )
+ [ adjlist ]
+ [ '[ , , 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ delete-blank-vertex ] 2tri ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
+ [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
+
+: (depth-first) ( v pre post -- )
+ { [ 2drop visited? get t -rot set-at ]
+ [ drop call ]
+ [ [ graph get adjlist ] 2dip
+ '[ dup visited? get at [ drop ] [ , , (depth-first) ] if ] each ]
+ [ nip call ] } 3cleave ; inline
+
+PRIVATE>
+
+: depth-first ( v graph pre post -- ?list ? )
+ '[ , , (depth-first) visited? get ] swap search-wrap ; inline
+
+: full-depth-first ( graph pre post tail -- ? )
+ '[ [ visited? get [ nip not ] assoc-find ]
+ [ drop , , (depth-first) @ ]
+ [ 2drop ] while ] swap search-wrap ; inline
+
+: dag? ( graph -- ? )
+ V{ } clone swap [ 2dup swap push dupd
+ '[ , swap graph get adj? not ] all?
+ [ end-search ] unless ]
+ [ drop dup pop* ] [ ] full-depth-first nip ;
+
+: topological-sort ( graph -- seq/f )
+ dup dag?
+ [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
diff --git a/extra/graph-theory/reversals/reversals.factor b/extra/graph-theory/reversals/reversals.factor
new file mode 100644
index 0000000000..1ea1a3fbf5
--- /dev/null
+++ b/extra/graph-theory/reversals/reversals.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel graph-theory ;
+
+IN: graph-theory.reversals
+
+TUPLE: reversal graph ;
+
+GENERIC: reverse-graph ( graph -- reversal )
+
+M: graph reverse-graph reversal boa ;
+
+M: reversal reverse-graph graph>> ;
+
+INSTANCE: reversal graph
+
+M: reversal vertices
+ graph>> vertices ;
+
+M: reversal adj?
+ swapd graph>> adj? ;
diff --git a/extra/graph-theory/sparse/sparse.factor b/extra/graph-theory/sparse/sparse.factor
new file mode 100644
index 0000000000..33c5505f0a
--- /dev/null
+++ b/extra/graph-theory/sparse/sparse.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
+
+IN: graph-theory.sparse
+
+TUPLE: sparse-graph alist ;
+
+: <sparse-graph> ( -- sparse-graph )
+ H{ } clone sparse-graph boa ;
+
+: >sparse-graph ( graph -- sparse-graph )
+ [ vertices ] keep
+ '[ dup , adjlist 2array ] map >hashtable sparse-graph boa ;
+
+INSTANCE: sparse-graph graph
+
+M: sparse-graph vertices
+ alist>> keys ;
+
+M: sparse-graph adjlist
+ alist>> at ;
+
+M: sparse-graph add-blank-vertex
+ alist>> V{ } clone -rot set-at ;
+
+M: sparse-graph delete-blank-vertex
+ alist>> delete-at ;
+
+M: sparse-graph add-edge*
+ alist>> swapd at adjoin ;
+
+M: sparse-graph delete-edge*
+ alist>> swapd at delete ;
From 65cc3f40510c01ed5c4651749d8b1875a7e7b012 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Fri, 20 Jun 2008 23:53:47 -0400
Subject: [PATCH 54/85] Added authors.txt, etc. to graph-theory
---
extra/graph-theory/authors.txt | 1 +
extra/graph-theory/summary.txt | 1 +
extra/graph-theory/tags.txt | 1 +
3 files changed, 3 insertions(+)
create mode 100644 extra/graph-theory/authors.txt
create mode 100644 extra/graph-theory/summary.txt
create mode 100644 extra/graph-theory/tags.txt
diff --git a/extra/graph-theory/authors.txt b/extra/graph-theory/authors.txt
new file mode 100644
index 0000000000..93667236de
--- /dev/null
+++ b/extra/graph-theory/authors.txt
@@ -0,0 +1 @@
+William Schlieper
diff --git a/extra/graph-theory/summary.txt b/extra/graph-theory/summary.txt
new file mode 100644
index 0000000000..3e1d791ab1
--- /dev/null
+++ b/extra/graph-theory/summary.txt
@@ -0,0 +1 @@
+Graph-theoretic algorithms
diff --git a/extra/graph-theory/tags.txt b/extra/graph-theory/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/extra/graph-theory/tags.txt
@@ -0,0 +1 @@
+collections
From f0a1f8fe5fa709e318ccf1c3a4ac57a5408a3c29 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 21 Jun 2008 16:56:21 +1200
Subject: [PATCH 55/85] Fix JavaScript new expression
---
extra/peg/javascript/parser/parser.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 5eb42daa31..d44bbcf675 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -89,7 +89,8 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| String => [[ ast-string boa ]]
| RegExp => [[ ast-regexp boa ]]
| "function" FuncRest:fr => [[ fr ]]
- | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "new" PrimExpr:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "new" PrimExpr:n => [[ n f ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
| Json
JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
From 75814c35f4697d2c7970170808059769bda5c741 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 24 Jun 2008 10:50:41 +1200
Subject: [PATCH 56/85] Fix MulExpr to use Unary on rhs
---
extra/peg/javascript/parser/parser.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index d44bbcf675..b7df9908da 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -60,9 +60,9 @@ RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop
AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
| AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
| MulExpr
-MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
- | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
- | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
+MulExpr = MulExpr:x "*" Unary:y => [[ x y "*" ast-binop boa ]]
+ | MulExpr:x "/" Unary:y => [[ x y "/" ast-binop boa ]]
+ | MulExpr:x "%" Unary:y => [[ x y "%" ast-binop boa ]]
| Unary
Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
| "+" Postfix:p => [[ p ]]
From 6923b32ebfcc26f06c2cd60d89311078eb4365c5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 08:35:06 -0500
Subject: [PATCH 57/85] Add combinators.short-circuit
---
.../short-circuit/short-circuit.factor | 43 +++++++++++++++++++
1 file changed, 43 insertions(+)
create mode 100644 extra/combinators/short-circuit/short-circuit.factor
diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor
new file mode 100644
index 0000000000..cda8ea4706
--- /dev/null
+++ b/extra/combinators/short-circuit/short-circuit.factor
@@ -0,0 +1,43 @@
+
+USING: kernel combinators quotations arrays sequences assocs macros fry ;
+
+IN: combinators.short-circuit
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: short-circuit ( quots quot default -- quot )
+ 1quotation -rot { } map>assoc <reversed> alist>quot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 0&& ( quots -- quot )
+ [ '[ drop @ dup not ] [ drop f ] 2array ] map
+ { [ t ] [ ] } suffix
+ '[ f , cond ] ;
+
+MACRO: 1&& ( quots -- quot )
+ [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
+ { [ t ] [ nip ] } suffix
+ '[ f , cond ] ;
+
+MACRO: 2&& ( quots -- quot )
+ [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
+ { [ t ] [ 2nip ] } suffix
+ '[ f , cond ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 0|| ( quots -- quot )
+ [ '[ drop @ dup ] [ ] 2array ] map
+ { [ drop t ] [ f ] } suffix
+ '[ f , cond ] ;
+
+MACRO: 1|| ( quots -- quot )
+ [ '[ drop dup @ dup ] [ nip ] 2array ] map
+ { [ drop drop t ] [ f ] } suffix
+ '[ f , cond ] ;
+
+MACRO: 2|| ( quots -- quot )
+ [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
+ { [ drop 2drop t ] [ f ] } suffix
+ '[ f , cond ] ;
From e88b83b32f33a5831f29478b98f5c45470a1d9ac Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 08:35:36 -0500
Subject: [PATCH 58/85] Update vocabs for combinators.short-circuit
---
extra/combinators/lib/lib.factor | 52 ++++++++++++------------
extra/http/parsers/parsers.factor | 2 +-
extra/unicode/breaks/breaks.factor | 2 +-
extra/unicode/collation/collation.factor | 2 +-
extra/unicode/data/data.factor | 2 +-
5 files changed, 30 insertions(+), 30 deletions(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index fe6b68638b..d9509b30f4 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -63,42 +63,42 @@ MACRO: napply ( n -- )
! short circuiting words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: short-circuit ( quots quot default -- quot )
- 1quotation -rot { } map>assoc <reversed> alist>quot ;
+! : short-circuit ( quots quot default -- quot )
+! 1quotation -rot { } map>assoc <reversed> alist>quot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 0&& ( quots -- quot )
- [ '[ drop @ dup not ] [ drop f ] 2array ] map
- { [ t ] [ ] } suffix
- '[ f , cond ] ;
+! MACRO: 0&& ( quots -- quot )
+! [ '[ drop @ dup not ] [ drop f ] 2array ] map
+! { [ t ] [ ] } suffix
+! '[ f , cond ] ;
-MACRO: 1&& ( quots -- quot )
- [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
- { [ t ] [ nip ] } suffix
- '[ f , cond ] ;
+! MACRO: 1&& ( quots -- quot )
+! [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
+! { [ t ] [ nip ] } suffix
+! '[ f , cond ] ;
-MACRO: 2&& ( quots -- quot )
- [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
- { [ t ] [ 2nip ] } suffix
- '[ f , cond ] ;
+! MACRO: 2&& ( quots -- quot )
+! [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
+! { [ t ] [ 2nip ] } suffix
+! '[ f , cond ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 0|| ( quots -- quot )
- [ '[ drop @ dup ] [ ] 2array ] map
- { [ drop t ] [ f ] } suffix
- '[ f , cond ] ;
+! MACRO: 0|| ( quots -- quot )
+! [ '[ drop @ dup ] [ ] 2array ] map
+! { [ drop t ] [ f ] } suffix
+! '[ f , cond ] ;
-MACRO: 1|| ( quots -- quot )
- [ '[ drop dup @ dup ] [ nip ] 2array ] map
- { [ drop drop t ] [ f ] } suffix
- '[ f , cond ] ;
+! MACRO: 1|| ( quots -- quot )
+! [ '[ drop dup @ dup ] [ nip ] 2array ] map
+! { [ drop drop t ] [ f ] } suffix
+! '[ f , cond ] ;
-MACRO: 2|| ( quots -- quot )
- [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
- { [ drop 2drop t ] [ f ] } suffix
- '[ f , cond ] ;
+! MACRO: 2|| ( quots -- quot )
+! [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
+! { [ drop 2drop t ] [ f ] } suffix
+! '[ f , cond ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor
index 33bfa4b202..bc6e1148c3 100644
--- a/extra/http/parsers/parsers.factor
+++ b/extra/http/parsers/parsers.factor
@@ -1,4 +1,4 @@
-USING: math math.order math.parser kernel combinators.lib
+USING: combinators.short-circuit math math.order math.parser kernel combinators.lib
sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces ascii ;
IN: http.parsers
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index b70d79b872..745fb83c3c 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,4 +1,4 @@
-USING: unicode.categories kernel math combinators splitting
+USING: combinators.short-circuit unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
math.ranges unicode.normalize values io.encodings.ascii
unicode.syntax unicode.data compiler.units alien.syntax sets
diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor
index 216f80c79d..8deed708e6 100755
--- a/extra/unicode/collation/collation.factor
+++ b/extra/unicode/collation/collation.factor
@@ -1,4 +1,4 @@
-USING: sequences io.files io.encodings.ascii kernel values
+USING: combinators.short-circuit sequences io.files io.encodings.ascii kernel values
splitting accessors math.parser ascii io assocs strings math
namespaces sorting combinators math.order arrays
unicode.normalize unicode.data combinators.lib locals
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 5fb769e499..b6c6292e90 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,4 +1,4 @@
-USING: assocs math kernel sequences io.files hashtables
+USING: combinators.short-circuit assocs math kernel sequences io.files hashtables
quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
io.encodings.ascii values interval-maps ascii sets
From 8cd16e5bf8c65f0f0437c7e2ba2a9bf2bf9eee6b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 10:39:50 -0500
Subject: [PATCH 59/85] combinators.short-circuit: n&&-rewrite and n||-rewrite
---
.../short-circuit/short-circuit.factor | 47 +++++++++----------
1 file changed, 21 insertions(+), 26 deletions(-)
diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor
index cda8ea4706..1738e8ec38 100644
--- a/extra/combinators/short-circuit/short-circuit.factor
+++ b/extra/combinators/short-circuit/short-circuit.factor
@@ -1,5 +1,6 @@
-USING: kernel combinators quotations arrays sequences assocs macros fry ;
+USING: kernel combinators quotations arrays sequences assocs
+ locals shuffle macros fry newfx ;
IN: combinators.short-circuit
@@ -10,34 +11,28 @@ IN: combinators.short-circuit
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 0&& ( quots -- quot )
- [ '[ drop @ dup not ] [ drop f ] 2array ] map
- { [ t ] [ ] } suffix
- '[ f , cond ] ;
+:: n&&-rewrite ( quots N -- quot )
+ quots
+ [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
+ map
+ [ t ] [ N nnip ] 2array suffix
+ '[ f , cond ] ;
-MACRO: 1&& ( quots -- quot )
- [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
- { [ t ] [ nip ] } suffix
- '[ f , cond ] ;
-
-MACRO: 2&& ( quots -- quot )
- [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
- { [ t ] [ 2nip ] } suffix
- '[ f , cond ] ;
+MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
+MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
+MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 0|| ( quots -- quot )
- [ '[ drop @ dup ] [ ] 2array ] map
- { [ drop t ] [ f ] } suffix
- '[ f , cond ] ;
+:: n||-rewrite ( quots N -- quot )
+ quots
+ [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
+ map
+ [ drop N ndrop t ] [ f ] 2array suffix
+ '[ f , cond ] ;
-MACRO: 1|| ( quots -- quot )
- [ '[ drop dup @ dup ] [ nip ] 2array ] map
- { [ drop drop t ] [ f ] } suffix
- '[ f , cond ] ;
+MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
+MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
+MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
-MACRO: 2|| ( quots -- quot )
- [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
- { [ drop 2drop t ] [ f ] } suffix
- '[ f , cond ] ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From e1b9e3485ae0f8524849902f5eed3473ca7a8183 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 10:40:27 -0500
Subject: [PATCH 60/85] combinators.short-circuit: tests
---
.../short-circuit/short-circuit-tests.factor | 32 +++++++++++++++++++
1 file changed, 32 insertions(+)
create mode 100644 extra/combinators/short-circuit/short-circuit-tests.factor
diff --git a/extra/combinators/short-circuit/short-circuit-tests.factor b/extra/combinators/short-circuit/short-circuit-tests.factor
new file mode 100644
index 0000000000..e392d67d2a
--- /dev/null
+++ b/extra/combinators/short-circuit/short-circuit-tests.factor
@@ -0,0 +1,32 @@
+
+USING: kernel math tools.test combinators.short-circuit ;
+
+IN: combinators.short-circuit.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t
+[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t
+[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
+
+[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f
+[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f
+[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
+
+[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t
+
+[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t
+
+[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
From 945fe1bc748cc0f136557cad63f43ef7bc074b5c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 10:40:55 -0500
Subject: [PATCH 61/85] Add combinators.short-circuit.smart
---
.../short-circuit/smart/smart-tests.factor | 32 +++++++++++++++++++
.../short-circuit/smart/smart.factor | 11 +++++++
2 files changed, 43 insertions(+)
create mode 100644 extra/combinators/short-circuit/smart/smart-tests.factor
create mode 100644 extra/combinators/short-circuit/smart/smart.factor
diff --git a/extra/combinators/short-circuit/smart/smart-tests.factor b/extra/combinators/short-circuit/smart/smart-tests.factor
new file mode 100644
index 0000000000..7ec4a0e657
--- /dev/null
+++ b/extra/combinators/short-circuit/smart/smart-tests.factor
@@ -0,0 +1,32 @@
+
+USING: kernel math tools.test combinators.short-circuit.smart ;
+
+IN: combinators.short-circuit.smart.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
+[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
+[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
+
+[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
+[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
+[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
+
+[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
+
+[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
+
+[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
diff --git a/extra/combinators/short-circuit/smart/smart.factor b/extra/combinators/short-circuit/smart/smart.factor
new file mode 100644
index 0000000000..2cef957a6f
--- /dev/null
+++ b/extra/combinators/short-circuit/smart/smart.factor
@@ -0,0 +1,11 @@
+
+USING: kernel sequences math inference accessors macros
+ combinators.short-circuit ;
+
+IN: combinators.short-circuit.smart
+
+MACRO: && ( quots -- quot )
+ dup first infer [ in>> ] [ out>> ] bi - 1+ n&&-rewrite ;
+
+MACRO: || ( quots -- quot )
+ dup first infer [ in>> ] [ out>> ] bi - 1+ n||-rewrite ;
From bf238283daf7b2bee71e554100565e7fa90a6506 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 13:47:54 -0500
Subject: [PATCH 62/85] Update code for combinators.short-circuit
---
extra/boids/boids.factor | 2 +-
extra/boids/ui/ui.factor | 2 +-
extra/dns/forwarding/forwarding.factor | 2 +-
extra/dns/server/server.factor | 2 +-
extra/ftp/server/server.factor | 2 +-
extra/inverse/inverse.factor | 2 +-
extra/io/servers/connection/connection.factor | 2 +-
extra/lcs/lcs.factor | 3 ++-
extra/lisp/lisp.factor | 2 +-
extra/lisp/parser/parser.factor | 2 +-
extra/lsys/strings/interpret/interpret.factor | 2 +-
extra/lsys/strings/rewrite/rewrite.factor | 2 +-
extra/lsys/strings/strings.factor | 2 +-
extra/lsys/tortoise/graphics/graphics.factor | 2 +-
extra/lsys/ui/ui.factor | 3 ++-
extra/math/text/english/english.factor | 3 ++-
extra/peg/ebnf/ebnf.factor | 3 ++-
extra/project-euler/014/014.factor | 2 +-
extra/project-euler/017/017.factor | 2 +-
extra/project-euler/021/021.factor | 3 ++-
extra/project-euler/036/036.factor | 2 +-
extra/project-euler/043/043.factor | 3 ++-
extra/project-euler/052/052.factor | 3 ++-
extra/project-euler/project-euler.factor | 2 +-
extra/regexp/regexp.factor | 3 ++-
extra/shell/shell.factor | 3 ++-
extra/xmode/marker/marker.factor | 3 ++-
27 files changed, 37 insertions(+), 27 deletions(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 4151b44cfb..e6c97b90dd 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -1,5 +1,5 @@
-USING: kernel namespaces
+USING: combinators.short-circuit kernel namespaces
math
math.constants
math.functions
diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor
index a1feac381d..3b28e79bcf 100755
--- a/extra/boids/ui/ui.factor
+++ b/extra/boids/ui/ui.factor
@@ -1,5 +1,5 @@
-USING: kernel namespaces
+USING: combinators.short-circuit kernel namespaces
math
math.functions
math.vectors
diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor
index 039b969ddd..87f9821153 100644
--- a/extra/dns/forwarding/forwarding.factor
+++ b/extra/dns/forwarding/forwarding.factor
@@ -1,5 +1,5 @@
-USING: kernel
+USING: combinators.short-circuit kernel
combinators
vectors
sequences
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index 04b3ecfbee..16677d8761 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -1,7 +1,7 @@
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
- combinators.cleave combinators.lib
+ combinators.cleave combinators.lib combinators.short-circuit
newfx fry
dns dns.util dns.misc ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index c71eadb72f..c5a5449b25 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io io.encodings.8-bit
+USING: combinators.short-circuit accessors combinators io io.encodings.8-bit
io.encodings io.encodings.binary io.encodings.utf8 io.files
io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index ef1f575972..43507046d6 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -2,7 +2,7 @@ USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
classes.tuple namespaces vectors bit-arrays byte-arrays strings
sbufs math.functions macros sequences.private combinators
-mirrors combinators.lib ;
+mirrors combinators.lib combinators.short-circuit ;
IN: inverse
TUPLE: fail ;
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
index b062322142..0ff83261fb 100755
--- a/extra/io/servers/connection/connection.factor
+++ b/extra/io/servers/connection/connection.factor
@@ -6,7 +6,7 @@ quotations combinators combinators.lib logging calendar assocs
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators
-concurrency.semaphores ;
+concurrency.semaphores combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index 4b0fb53f5e..2fa0b6cc71 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -1,5 +1,6 @@
USING: sequences kernel math locals math.order math.ranges
-accessors combinators.lib arrays namespaces combinators ;
+accessors combinators.lib arrays namespaces combinators
+combinators.short-circuit ;
IN: lcs
<PRIVATE
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e3d942d390..109083de37 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -3,7 +3,7 @@
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
-quotations fry lists inspector ;
+quotations fry lists inspector combinators.short-circuit ;
IN: lisp
DEFER: convert-form
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 8fadb00e65..428e1221da 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
-combinators.lib math fry accessors lists ;
+combinators.lib math fry accessors lists combinators.short-circuit ;
IN: lisp.parser
diff --git a/extra/lsys/strings/interpret/interpret.factor b/extra/lsys/strings/interpret/interpret.factor
index bcd87ca137..1d992cc1e2 100644
--- a/extra/lsys/strings/interpret/interpret.factor
+++ b/extra/lsys/strings/interpret/interpret.factor
@@ -1,6 +1,6 @@
USING: kernel sequences quotations assocs math math.parser
- combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.interpret
diff --git a/extra/lsys/strings/rewrite/rewrite.factor b/extra/lsys/strings/rewrite/rewrite.factor
index eb76dbd751..622a86c425 100644
--- a/extra/lsys/strings/rewrite/rewrite.factor
+++ b/extra/lsys/strings/rewrite/rewrite.factor
@@ -1,6 +1,6 @@
USING: kernel sbufs strings sequences assocs math
- combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.rewrite
diff --git a/extra/lsys/strings/strings.factor b/extra/lsys/strings/strings.factor
index f184ca5dfc..603c6cc630 100644
--- a/extra/lsys/strings/strings.factor
+++ b/extra/lsys/strings/strings.factor
@@ -1,5 +1,5 @@
-USING: kernel sequences math combinators.lib ;
+USING: kernel sequences math combinators.lib combinators.short-circuit ;
IN: lsys.strings
diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor
index d75915ae8e..ab679c8369 100644
--- a/extra/lsys/tortoise/graphics/graphics.factor
+++ b/extra/lsys/tortoise/graphics/graphics.factor
@@ -2,7 +2,7 @@
USING: kernel math vectors sequences opengl.gl math.vectors math.order
math.matrices vars opengl self pos ori turtle lsys.tortoise
- lsys.strings.interpret ;
+ lsys.strings.interpret combinators.short-circuit ;
! lsys.strings
diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor
index c3b9190c3c..d15793c15a 100644
--- a/extra/lsys/ui/ui.factor
+++ b/extra/lsys/ui/ui.factor
@@ -16,7 +16,8 @@ USING: kernel namespaces threads math math.order math.vectors
vars rewrite-closures
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics
- lsys.strings.rewrite lsys.strings.interpret ;
+ lsys.strings.rewrite lsys.strings.interpret
+ combinators.short-circuit ;
! lsys.strings
! lsys.strings.rewrite
diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index 500e08f79d..b8256533bf 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting grouping sequences.lib ;
+ sequences splitting grouping sequences.lib
+ combinators.short-circuit ;
IN: math.text.english
<PRIVATE
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index fc10a65024..e3d44585a7 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,8 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
- splitting accessors effects sequences.deep peg.search ;
+ splitting accessors effects sequences.deep peg.search
+ combinators.short-circuit ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index ef8ef8c0f7..b99e34d36f 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces sequences
- sorting ;
+ sorting combinators.short-circuit ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor
index ffff10d4fe..cf58e88ffe 100644
--- a/extra/project-euler/017/017.factor
+++ b/extra/project-euler/017/017.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.ranges math.text.english sequences sequences.lib strings
- ascii ;
+ ascii combinators.short-circuit ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor
index e6eadba264..f09b0c0b42 100644
--- a/extra/project-euler/021/021.factor
+++ b/extra/project-euler/021/021.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.ranges namespaces
- project-euler.common sequences sequences.lib ;
+ project-euler.common sequences sequences.lib
+ combinators.short-circuit ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21
diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor
index fbf6376eb3..4a4f906467 100644
--- a/extra/project-euler/036/036.factor
+++ b/extra/project-euler/036/036.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.parser math.ranges project-euler.common
- sequences ;
+ sequences combinators.short-circuit ;
IN: project-euler.036
! http://projecteuler.net/index.php?section=problems&id=36
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 0c51146656..e095d94ead 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sequences.lib sorting sets ;
+ math.ranges project-euler.common sequences sequences.lib sorting
+ sets combinators.short-circuit ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index 6c4b605bd9..194530ea78 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -1,6 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel math project-euler.common sequences sorting ;
+USING: combinators.lib kernel math project-euler.common sequences
+sorting combinators.short-circuit ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 9325e74d93..3101c900e3 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -17,7 +17,7 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
project-euler.052 project-euler.053 project-euler.056 project-euler.059
project-euler.067 project-euler.075 project-euler.079 project-euler.092
project-euler.097 project-euler.134 project-euler.169 project-euler.173
- project-euler.175 ;
+ project-euler.175 combinators.short-circuit ;
IN: project-euler
<PRIVATE
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 99e6b887c8..bdf0c411b2 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -1,7 +1,8 @@
USING: arrays combinators kernel lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
-assocs prettyprint.backend memoize unicode.case unicode.categories ;
+assocs prettyprint.backend memoize unicode.case unicode.categories
+combinators.short-circuit ;
USE: io
IN: regexp
diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor
index 8ba5b66d5a..45c6f1fb4d 100644
--- a/extra/shell/shell.factor
+++ b/extra/shell/shell.factor
@@ -2,7 +2,8 @@
USING: kernel parser words continuations namespaces debugger
sequences combinators splitting prettyprint
system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
- accessors multi-methods newfx shell.parser ;
+ accessors multi-methods newfx shell.parser
+ combinators.short-circuit ;
IN: shell
diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor
index 7d82842327..911397cc20 100755
--- a/extra/xmode/marker/marker.factor
+++ b/extra/xmode/marker/marker.factor
@@ -2,7 +2,8 @@ IN: xmode.marker
USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib
-strings regexp splitting parser-combinators ascii unicode.case ;
+strings regexp splitting parser-combinators ascii unicode.case
+combinators.short-circuit ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
From 7aea2ec62ce089c1865d0637f87dbf5c96a878a6 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 18:07:41 -0500
Subject: [PATCH 63/85] combinators.lib tests: minor update
---
extra/combinators/lib/lib-tests.factor | 29 --------------------------
1 file changed, 29 deletions(-)
diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor
index 78916bb027..680e3220b0 100755
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@@ -23,35 +23,6 @@ IN: combinators.lib.tests
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
] unit-test
-! &&
-
-[ t ] [
- 3 {
- [ dup number? ] [ dup odd? ] [ dup 0 > ]
- } 0&& nip
-] unit-test
-
-[ f ] [
- 3 {
- [ dup number? ] [ dup even? ] [ dup 0 > ]
- } 0&& nip
-] unit-test
-
-! ||
-
-[ t ] [
- 4 {
- [ dup array? ] [ dup number? ] [ 3 throw ]
- } 0|| nip
-] unit-test
-
-[ f ] [
- 4 {
- [ dup array? ] [ dup vector? ] [ dup float? ]
- } 0|| nip
-] unit-test
-
-
{ 1 1 } [
[ even? ] [ drop 1 ] [ drop 2 ] ifte
] must-infer-as
From ec3c47d9572328a0fa689831ef461083c91332a3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 18:10:17 -0500
Subject: [PATCH 64/85] furnace.sessions: uses 0||
---
extra/furnace/sessions/sessions.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index 6e50417ea1..0ec9648a67 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -7,7 +7,7 @@ io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
-furnace furnace.cache ;
+furnace furnace.cache combinators.short-circuit ;
IN: furnace.sessions
TUPLE: session < server-state namespace user-agent client changed? ;
From 74f2627526a5abc928c7a8e51da8c9337b270254 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 24 Jun 2008 18:33:08 -0500
Subject: [PATCH 65/85] More short-circuit updates
---
extra/furnace/auth/login/permits/permits.factor | 4 +++-
extra/furnace/boilerplate/boilerplate.factor | 2 +-
2 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor
index 49cf98e0e3..ae9458f4ac 100644
--- a/extra/furnace/auth/login/permits/permits.factor
+++ b/extra/furnace/auth/login/permits/permits.factor
@@ -1,6 +1,8 @@
USING: accessors namespaces combinators.lib kernel
db.tuples db.types
-furnace.auth furnace.sessions furnace.cache ;
+furnace.auth furnace.sessions furnace.cache
+combinators.short-circuit ;
+
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor
index 0e2a673d9b..2bb97e7c14 100644
--- a/extra/furnace/boilerplate/boilerplate.factor
+++ b/extra/furnace/boilerplate/boilerplate.factor
@@ -7,7 +7,7 @@ html.templates.chloe
locals
http.server
http.server.filters
-furnace ;
+furnace combinators.short-circuit ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ;
From 6e0d35e6153bab5afdf8a1c4b95bfb3a8d2af599 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 03:25:08 -0500
Subject: [PATCH 66/85] Split up huge parser vocabulary
---
core/alien/syntax/syntax.factor | 3 +-
core/classes/classes.factor | 9 +
core/classes/intersection/intersection.factor | 3 -
core/classes/mixin/mixin.factor | 2 +-
core/classes/parser/parser.factor | 15 +
core/classes/predicate/predicate.factor | 9 +-
core/classes/tuple/parser/parser-docs.factor | 14 +
core/classes/tuple/parser/parser.factor | 50 +++
core/classes/tuple/tuple.factor | 10 +-
core/classes/union/union.factor | 3 -
core/continuations/continuations-docs.factor | 8 +-
core/cpu/x86/assembler/assembler.factor | 20 +-
core/cpu/x86/assembler/syntax/syntax.factor | 15 +
core/effects/parser/parser-docs.factor | 9 +
core/effects/parser/parser.factor | 15 +
core/generic/parser/parser.factor | 33 ++
core/lexer/lexer-docs.factor | 114 +++++++
core/lexer/lexer.factor | 133 ++++++++
core/listener/listener.factor | 4 +-
core/parser/parser-docs.factor | 152 +--------
core/parser/parser-tests.factor | 6 +
core/parser/parser.factor | 318 +-----------------
core/source-files/source-files.factor | 27 +-
core/strings/parser/parser-docs.factor | 16 +
core/strings/parser/parser.factor | 62 ++++
core/syntax/syntax.factor | 15 +-
extra/bitfields/bitfields.factor | 2 +-
extra/bootstrap/unicode/unicode.factor | 2 +-
extra/cocoa/cocoa.factor | 3 +-
extra/cpu/8080/emulator/emulator.factor | 2 +-
extra/editors/editors-docs.factor | 4 +-
extra/editors/editors.factor | 34 +-
extra/gesture-logger/gesture-logger.factor | 3 +-
extra/help/handbook/handbook.factor | 2 +-
.../html/templates/chloe/syntax/syntax.factor | 2 +-
extra/html/templates/fhtml/fhtml.factor | 6 +-
extra/http/http-tests.factor | 6 +
extra/http/http.factor | 5 +-
extra/io/encodings/8-bit/8-bit-docs.factor | 9 +-
extra/locals/locals.factor | 4 +-
extra/match/match.factor | 2 +-
extra/money/money.factor | 2 +-
extra/mortar/mortar.factor | 2 +-
extra/multiline/multiline.factor | 2 +-
extra/opengl/gl/extensions/extensions.factor | 2 +-
extra/openssl/libssl/libssl.factor | 2 +-
extra/qualified/qualified.factor | 6 +-
extra/regexp/regexp.factor | 2 +-
extra/semantic-db/semantic-db.factor | 2 +-
extra/state-machine/state-machine.factor | 2 +-
extra/symbols/symbols.factor | 3 +-
extra/tools/deploy/shaker/shaker.factor | 6 +-
extra/tuple-syntax/tuple-syntax.factor | 2 +-
extra/ui/tools/interactor/interactor.factor | 6 +-
extra/unicode/syntax/syntax.factor | 2 +-
extra/urls/urls.factor | 16 +-
extra/vars/vars.factor | 2 +-
extra/xml/generator/generator.factor | 4 +-
extra/xml/utilities/utilities.factor | 2 +-
extra/xmode/loader/syntax/syntax.factor | 2 +-
extra/xmode/utilities/utilities.factor | 2 +-
61 files changed, 642 insertions(+), 578 deletions(-)
create mode 100644 core/classes/parser/parser.factor
create mode 100644 core/classes/tuple/parser/parser-docs.factor
create mode 100644 core/classes/tuple/parser/parser.factor
create mode 100644 core/cpu/x86/assembler/syntax/syntax.factor
create mode 100644 core/effects/parser/parser-docs.factor
create mode 100644 core/effects/parser/parser.factor
create mode 100644 core/generic/parser/parser.factor
create mode 100644 core/lexer/lexer-docs.factor
create mode 100644 core/lexer/lexer.factor
create mode 100644 core/strings/parser/parser-docs.factor
create mode 100644 core/strings/parser/parser.factor
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index def5b02ba0..a756734f7b 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -3,7 +3,8 @@
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects prettyprint
-prettyprint.sections prettyprint.backend assocs combinators ;
+prettyprint.sections prettyprint.backend assocs combinators
+lexer strings.parser ;
IN: alien.syntax
<PRIVATE
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 0fef6de748..35ff475abf 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -65,6 +65,15 @@ GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
+M: class reset-class
+ {
+ "class"
+ "metaclass"
+ "superclass"
+ "members"
+ "participants"
+ } reset-props ;
+
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 7ea8e24f0a..cc24280384 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -27,7 +27,4 @@ M: intersection-class update-class define-intersection-predicate ;
[ drop update-classes ]
2bi ;
-M: intersection-class reset-class
- { "class" "metaclass" "participants" } reset-props ;
-
M: intersection-class rank-class drop 2 ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index a2debe55a1..3924eb264c 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
- { "class" "metaclass" "members" "mixin" } reset-props ;
+ [ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor
new file mode 100644
index 0000000000..17a7b23552
--- /dev/null
+++ b/core/classes/parser/parser.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words kernel classes compiler.units lexer ;
+IN: classes.parser
+
+: save-class-location ( class -- )
+ location remember-class ;
+
+: create-class-in ( word -- word )
+ current-vocab create
+ dup save-class-location
+ dup predicate-word dup set-word save-location ;
+
+: CREATE-CLASS ( -- word )
+ scan create-class-in ;
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index c8de36582e..7ea60149f8 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -24,11 +24,8 @@ PREDICATE: predicate-class < class
] 3tri ;
M: predicate-class reset-class
- {
- "class"
- "metaclass"
- "predicate-definition"
- "superclass"
- } reset-props ;
+ [ call-next-method ]
+ [ { "predicate-definition" } reset-props ]
+ bi ;
M: predicate-class rank-class drop 1 ;
diff --git a/core/classes/tuple/parser/parser-docs.factor b/core/classes/tuple/parser/parser-docs.factor
new file mode 100644
index 0000000000..f4ecb1461e
--- /dev/null
+++ b/core/classes/tuple/parser/parser-docs.factor
@@ -0,0 +1,14 @@
+IN: classes.tuple.parser
+USING: strings help.markup help.syntax ;
+
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+ { $code
+ "TUPLE: my-mistaken-tuple slot-a slot-b"
+ ""
+ ": some-word ( a b c -- ) ... ;"
+ }
+} ;
diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
new file mode 100644
index 0000000000..ab3be109e1
--- /dev/null
+++ b/core/classes/tuple/parser/parser.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sets namespaces sequences inspector parser
+lexer combinators words classes.parser classes.tuple ;
+IN: classes.tuple.parser
+
+: shadowed-slots ( superclass slots -- shadowed )
+ >r all-slot-names r> intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+ shadowed-slots [
+ [
+ "Definition of slot ``" %
+ %
+ "'' in class ``" %
+ word-name %
+ "'' shadows a superclass slot" %
+ ] "" make note.
+ ] with each ;
+
+ERROR: invalid-slot-name name ;
+
+M: invalid-slot-name summary
+ drop
+ "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+ #! This isn't meant to enforce any kind of policy, just
+ #! to check for mistakes of this form:
+ #!
+ #! TUPLE: blahblah foo bing
+ #!
+ #! : ...
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop ] }
+ [ , (parse-tuple-slots) ]
+ } cond ;
+
+: parse-tuple-slots ( -- seq )
+ [ (parse-tuple-slots) ] { } make ;
+
+: parse-tuple-definition ( -- class superclass slots )
+ CREATE-CLASS
+ scan {
+ { ";" [ tuple f ] }
+ { "<" [ scan-word parse-tuple-slots ] }
+ [ >r tuple parse-tuple-slots r> prefix ]
+ } case 3dup check-slot-shadowing ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 5ba0b7e69c..b4a2302a9e 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -217,13 +217,9 @@ M: tuple-class reset-class
[ writer-word method forget ] 2bi
] with each
] [
- {
- "class"
- "metaclass"
- "superclass"
- "layout"
- "slots"
- } reset-props
+ [ call-next-method ]
+ [ { "layout" "slots" } reset-props ]
+ bi
] bi ;
M: tuple-class rank-class drop 0 ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 74e29cfb01..819e0ecb0b 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -28,7 +28,4 @@ M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ (define-union-class) ] [ drop update-classes ] 2bi ;
-M: union-class reset-class
- { "class" "metaclass" "members" } reset-props ;
-
M: union-class rank-class drop 2 ;
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 3cb7d8a71e..f176e6ee19 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
-continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+continuations.private vectors arrays namespaces
+assocs words quotations lexer ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@@ -169,8 +169,8 @@ HELP: rethrow
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
}
{ $examples
- "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
- { $see with-parser }
+ "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
+ { $see with-lexer }
} ;
HELP: throw-restarts
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 452a102341..f8e0b0abb0 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
-combinators kernel.private math namespaces parser sequences
-words system layouts math.order accessors ;
+combinators kernel.private math namespaces sequences
+words system layouts math.order accessors
+cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@@ -12,21 +13,6 @@ IN: cpu.x86.assembler
! Beware!
! Register operands -- eg, ECX
-<<
-
-: define-register ( name num size -- )
- >r >r "cpu.x86.assembler" create dup define-symbol r> r>
- >r dupd "register" set-word-prop r>
- "register-size" set-word-prop ;
-
-: define-registers ( names size -- )
- >r dup length r> [ define-register ] curry 2each ;
-
-: REGISTERS: ( -- )
- scan-word ";" parse-tokens swap define-registers ; parsing
-
->>
-
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
diff --git a/core/cpu/x86/assembler/syntax/syntax.factor b/core/cpu/x86/assembler/syntax/syntax.factor
new file mode 100644
index 0000000000..5940663d42
--- /dev/null
+++ b/core/cpu/x86/assembler/syntax/syntax.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences lexer parser ;
+IN: cpu.x86.assembler.syntax
+
+: define-register ( name num size -- )
+ >r >r "cpu.x86.assembler" create dup define-symbol r> r>
+ >r dupd "register" set-word-prop r>
+ "register-size" set-word-prop ;
+
+: define-registers ( names size -- )
+ >r dup length r> [ define-register ] curry 2each ;
+
+: REGISTERS: ( -- )
+ scan-word ";" parse-tokens swap define-registers ; parsing
diff --git a/core/effects/parser/parser-docs.factor b/core/effects/parser/parser-docs.factor
new file mode 100644
index 0000000000..6cb39d208d
--- /dev/null
+++ b/core/effects/parser/parser-docs.factor
@@ -0,0 +1,9 @@
+IN: effects.parser
+USING: strings effects help.markup help.syntax ;
+
+HELP: parse-effect
+{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
+{ $description "Parses a stack effect from the current input line." }
+{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
+$parsing-note ;
+
diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
new file mode 100644
index 0000000000..8f28450de7
--- /dev/null
+++ b/core/effects/parser/parser.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: lexer sets sequences kernel splitting effects ;
+IN: effects.parser
+
+: parse-effect ( end -- effect )
+ parse-tokens dup { "(" "((" } intersect empty? [
+ { "--" } split1 dup [
+ <effect>
+ ] [
+ "Stack effect declaration must contain --" throw
+ ] if
+ ] [
+ "Stack effect declaration must not contain ( or ((" throw
+ ] if ;
diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor
new file mode 100644
index 0000000000..ba9cd5244c
--- /dev/null
+++ b/core/generic/parser/parser.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel words generic namespaces inspector ;
+IN: generic.parser
+
+ERROR: not-in-a-method-error ;
+
+M: not-in-a-method-error summary
+ drop "call-next-method can only be called in a method definition" ;
+
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: create-method-in ( class generic -- method )
+ create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+ scan-word bootstrap-word scan-word create-method-in ;
+
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: with-method-definition ( quot -- parsed )
+ [
+ >r
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ r> call
+ ] with-scope ; inline
+
+: (M:) ( method def -- )
+ CREATE-METHOD [ parse-definition ] with-method-definition ;
+
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
new file mode 100644
index 0000000000..b61fc82a25
--- /dev/null
+++ b/core/lexer/lexer-docs.factor
@@ -0,0 +1,114 @@
+IN: lexer
+USING: help.markup help.syntax kernel math sequences strings
+words quotations ;
+
+: $parsing-note ( children -- )
+ drop
+ "This word should only be called from parsing words."
+ $notes ;
+
+HELP: lexer
+{ $var-description "Stores the current " { $link lexer } " instance." }
+{ $class-description "An object for tokenizing parser input. It has the following slots:"
+ { $list
+ { { $snippet "text" } " - the lines being parsed; an array of strings" }
+ { { $snippet "line" } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" }
+ { { $snippet "column" } " - the current column position, zero-based" }
+ }
+"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ;
+
+HELP: <lexer>
+{ $values { "text" "a sequence of strings" } { "lexer" lexer } }
+{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ;
+
+HELP: next-line
+{ $values { "lexer" lexer } }
+{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
+
+HELP: lexer-error
+{ $error-description "Thrown when the lexer encounters invalid input. A lexer error wraps an underlying error together with line and column numbers." } ;
+
+HELP: <lexer-error>
+{ $values { "msg" "an error" } { "error" lexer-error } }
+{ $description "Creates a new " { $link lexer-error } ", filling in the location information from the current " { $link lexer } "." } ;
+
+HELP: skip
+{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
+{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
+
+HELP: change-lexer-column
+{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
+{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
+
+HELP: skip-blank
+{ $values { "lexer" lexer } }
+{ $contract "Skips whitespace characters." }
+{ $notes "Custom lexers can implement this generic word." } ;
+
+HELP: skip-word
+{ $values { "lexer" lexer } }
+{ $contract
+ "Skips until the end of the current token."
+ $nl
+ "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line."
+}
+{ $notes "Custom lexers can implement this generic word." } ;
+
+HELP: still-parsing-line?
+{ $values { "lexer" lexer } { "?" "a boolean" } }
+{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
+
+HELP: parse-token
+{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
+
+HELP: scan
+{ $values { "str/f" "a " { $link string } " or " { $link f } } }
+{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+$parsing-note ;
+
+HELP: still-parsing?
+{ $values { "lexer" lexer } { "?" "a boolean" } }
+{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
+
+HELP: parse-tokens
+{ $values { "end" string } { "seq" "a new sequence of strings" } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
+{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+$parsing-note ;
+
+HELP: unexpected
+{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
+{ $description "Throws an " { $link unexpected } " error." }
+{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
+{ $examples
+ "Parsing the following snippet will throw this error:"
+ { $code "[ 1 2 3 }" }
+} ;
+
+HELP: unexpected-eof
+{ $values { "word" "a " { $link word } } }
+{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ;
+
+HELP: with-lexer
+{ $values { "lexer" lexer } { "quot" quotation } }
+{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ;
+
+HELP: lexer-factory
+{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
+
+
+ARTICLE: "parser-lexer" "The lexer"
+"A variable that encapsulate internal parser state:"
+{ $subsection lexer }
+"Creating a default lexer:"
+{ $subsection <lexer> }
+"A word to test of the end of input has been reached:"
+{ $subsection still-parsing? }
+"A word to advance the lexer to the next line:"
+{ $subsection next-line }
+"Two generic words to override the lexer's token boundary detection:"
+{ $subsection skip-blank }
+{ $subsection skip-word }
+"Utility combinator:"
+{ $subsection with-lexer } ;
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
new file mode 100644
index 0000000000..3d65fb95ca
--- /dev/null
+++ b/core/lexer/lexer.factor
@@ -0,0 +1,133 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces math words strings
+debugger io vectors arrays math.parser combinators inspector
+continuations ;
+IN: lexer
+
+TUPLE: lexer text line line-text line-length column ;
+
+: next-line ( lexer -- )
+ dup [ line>> ] [ text>> ] bi ?nth >>line-text
+ dup line-text>> length >>line-length
+ [ 1+ ] change-line
+ 0 >>column
+ drop ;
+
+: new-lexer ( text class -- lexer )
+ new
+ 0 >>line
+ swap >>text
+ dup next-line ; inline
+
+: <lexer> ( text -- lexer )
+ lexer new-lexer ;
+
+: skip ( i seq ? -- n )
+ over >r
+ [ swap CHAR: \s eq? xor ] curry find-from drop
+ [ r> drop ] [ r> length ] if* ;
+
+: change-lexer-column ( lexer quot -- )
+ swap
+ [ dup lexer-column swap lexer-line-text rot call ] keep
+ set-lexer-column ; inline
+
+GENERIC: skip-blank ( lexer -- )
+
+M: lexer skip-blank ( lexer -- )
+ [ t skip ] change-lexer-column ;
+
+GENERIC: skip-word ( lexer -- )
+
+M: lexer skip-word ( lexer -- )
+ [
+ 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
+ ] change-lexer-column ;
+
+: still-parsing? ( lexer -- ? )
+ dup lexer-line swap lexer-text length <= ;
+
+: still-parsing-line? ( lexer -- ? )
+ dup lexer-column swap lexer-line-length < ;
+
+: (parse-token) ( lexer -- str )
+ [ lexer-column ] keep
+ [ skip-word ] keep
+ [ lexer-column ] keep
+ lexer-line-text subseq ;
+
+: parse-token ( lexer -- str/f )
+ dup still-parsing? [
+ dup skip-blank
+ dup still-parsing-line?
+ [ (parse-token) ] [ dup next-line parse-token ] if
+ ] [ drop f ] if ;
+
+: scan ( -- str/f ) lexer get parse-token ;
+
+ERROR: unexpected want got ;
+
+GENERIC: expected>string ( obj -- str )
+
+M: f expected>string drop "end of input" ;
+M: word expected>string word-name ;
+M: string expected>string ;
+
+M: unexpected error.
+ "Expected " write
+ dup unexpected-want expected>string write
+ " but got " write
+ unexpected-got expected>string print ;
+
+PREDICATE: unexpected-eof < unexpected
+ unexpected-got not ;
+
+: unexpected-eof ( word -- * ) f unexpected ;
+
+: (parse-tokens) ( accum end -- accum )
+ scan 2dup = [
+ 2drop
+ ] [
+ [ pick push (parse-tokens) ] [ unexpected-eof ] if*
+ ] if ;
+
+: parse-tokens ( end -- seq )
+ 100 <vector> swap (parse-tokens) >array ;
+
+TUPLE: lexer-error line column line-text error ;
+
+: <lexer-error> ( msg -- error )
+ \ lexer-error new
+ lexer get
+ [ line>> >>line ]
+ [ column>> >>column ]
+ [ line-text>> >>line-text ]
+ tri
+ swap >>error ;
+
+: lexer-dump ( error -- )
+ [ line>> number>string ": " append ]
+ [ line-text>> dup string? [ drop "" ] unless ]
+ [ column>> 0 or ] tri
+ pick length + CHAR: \s <string>
+ [ write ] [ print ] [ write "^" print ] tri* ;
+
+M: lexer-error error.
+ [ lexer-dump ] [ error>> error. ] bi ;
+
+M: lexer-error summary
+ error>> summary ;
+
+M: lexer-error compute-restarts
+ error>> compute-restarts ;
+
+M: lexer-error error-help
+ error>> error-help ;
+
+: with-lexer ( lexer quot -- newquot )
+ [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
+
+SYMBOL: lexer-factory
+
+[ <lexer> ] lexer-factory set-global
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index e00e64f4bc..4e2a8c768e 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
-namespaces parser sequences strings io.styles
+namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors ;
IN: listener
@@ -51,7 +51,7 @@ SYMBOL: error-hook
listener-hook get call prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
- dup parse-error? [
+ dup lexer-error? [
error-hook get call
] [
rethrow
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 2ec9f2de54..1aecfbd60d 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units assocs ;
+quotations namespaces compiler.units assocs lexer ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
@@ -135,25 +135,6 @@ $nl
{ $subsection "defining-words" }
{ $subsection "parsing-tokens" } ;
-ARTICLE: "parser-lexer" "The lexer"
-"Two variables that encapsulate internal parser state:"
-{ $subsection file }
-{ $subsection lexer }
-"Creating a default lexer:"
-{ $subsection <lexer> }
-"A word to test of the end of input has been reached:"
-{ $subsection still-parsing? }
-"A word to advance the lexer to the next line:"
-{ $subsection next-line }
-"Two generic words to override the lexer's token boundary detection:"
-{ $subsection skip-blank }
-{ $subsection skip-word }
-"A utility used when parsing string literals:"
-{ $subsection parse-string }
-"The parser can be invoked with a custom lexer:"
-{ $subsection (parse-lines) }
-{ $subsection with-parser } ;
-
ARTICLE: "parser-files" "Parsing source files"
"The parser can run source files:"
{ $subsection run-file }
@@ -192,25 +173,6 @@ $nl
ABOUT: "parser"
-: $parsing-note ( children -- )
- drop
- "This word should only be called from parsing words."
- $notes ;
-
-HELP: lexer
-{ $var-description "Stores the current " { $link lexer } " instance." }
-{ $class-description "An object for tokenizing parser input. It has the following slots:"
- { $list
- { { $link lexer-text } " - the lines being parsed; an array of strings" }
- { { $link lexer-line } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" }
- { { $link lexer-column } " - the current column position, zero-based" }
- }
-"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ;
-
-HELP: <lexer>
-{ $values { "text" "a sequence of strings" } { "lexer" lexer } }
-{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ;
-
HELP: location
{ $values { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ;
@@ -226,73 +188,9 @@ HELP: parser-notes?
{ $values { "?" "a boolean" } }
{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ;
-HELP: next-line
-{ $values { "lexer" lexer } }
-{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
-
-HELP: parse-error
-{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ;
-
-HELP: <parse-error>
-{ $values { "msg" "an error" } { "error" parse-error } }
-{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ;
-
-HELP: skip
-{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
-{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
-
-HELP: change-lexer-column
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
-{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
-
-HELP: skip-blank
-{ $values { "lexer" lexer } }
-{ $contract "Skips whitespace characters." }
-{ $notes "Custom lexers can implement this generic word." } ;
-
-HELP: skip-word
-{ $values { "lexer" lexer } }
-{ $contract
- "Skips until the end of the current token."
- $nl
- "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line."
-}
-{ $notes "Custom lexers can implement this generic word." } ;
-
-HELP: still-parsing-line?
-{ $values { "lexer" lexer } { "?" "a boolean" } }
-{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
-
-HELP: parse-token
-{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
-{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
-
-HELP: scan
-{ $values { "str/f" "a " { $link string } " or " { $link f } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
-$parsing-note ;
-
-HELP: bad-escape
-{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ;
-
HELP: bad-number
{ $error-description "Indicates the parser encountered an invalid numeric literal." } ;
-HELP: escape
-{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
-{ $description "Converts from a single-character escape code and the corresponding character." }
-{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
-
-HELP: parse-string
-{ $values { "str" "a new " { $link string } } }
-{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
-{ $errors "Throws an error if the string contains an invalid escape sequence." }
-$parsing-note ;
-
-HELP: still-parsing?
-{ $values { "lexer" lexer } { "?" "a boolean" } }
-{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
-
HELP: use
{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ;
@@ -338,12 +236,6 @@ HELP: create-in
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
$parsing-note ;
-HELP: parse-tokens
-{ $values { "end" string } { "seq" "a new sequence of strings" } }
-{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
-{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
-$parsing-note ;
-
HELP: CREATE
{ $values { "word" word } }
{ $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." }
@@ -369,31 +261,6 @@ HELP: scan-word
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
-HELP: invalid-slot-name
-{ $values { "name" string } }
-{ $description "Throws an " { $link invalid-slot-name } " error." }
-{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
-{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
- { $code
- "TUPLE: my-mistaken-tuple slot-a slot-b"
- ""
- ": some-word ( a b c -- ) ... ;"
- }
-} ;
-
-HELP: unexpected
-{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
-{ $description "Throws an " { $link unexpected } " error." }
-{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
-{ $examples
- "Parsing the following snippet will throw this error:"
- { $code "[ 1 2 3 }" }
-} ;
-
-HELP: unexpected-eof
-{ $values { "word" "a " { $link word } } }
-{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ;
-
HELP: parse-step
{ $values { "accum" vector } { "end" word } { "?" "a boolean" } }
{ $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." }
@@ -417,28 +284,15 @@ HELP: parsed
{ $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." }
$parsing-note ;
-HELP: with-parser
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( -- accum )" } } { "newquot" "a new " { $link quotation } } }
-{ $description "Sets up the parser and calls the quotation. The quotation can make use of parsing words such as " { $link scan } " and " { $link parse-until } ". It must yield a sequence, which is converted to a quotation and output. Any errors thrown by the quotation are wrapped in parse errors." } ;
-
HELP: (parse-lines)
{ $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }
{ $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." }
-{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ;
+{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-lines
{ $values { "lines" "a sequence of strings" } { "quot" "a new " { $link quotation } } }
{ $description "Parses Factor source code which has been tokenized into lines. The vocabulary search path is taken from the current scope." }
-{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ;
-
-HELP: lexer-factory
-{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
-
-HELP: parse-effect
-{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
-{ $description "Parses a stack effect from the current input line." }
-{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
-$parsing-note ;
+{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } }
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 555c6eb32c..eb37d556d0 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -485,3 +485,9 @@ must-fail-with
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
+
+[
+ "IN: parser.tests : blah ; parsing FORGET: blah" eval
+] [
+ error>> staging-violation?
+] must-fail-with
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 129d5ef2ee..44708f11f3 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -4,38 +4,17 @@ USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.streams.string vocabs
-io.encodings.utf8 source-files classes classes.tuple hashtables
-compiler.errors compiler.units accessors sets ;
+io.encodings.utf8 source-files classes hashtables
+compiler.errors compiler.units accessors sets lexer ;
IN: parser
-TUPLE: lexer text line line-text line-length column ;
-
-: next-line ( lexer -- )
- dup [ line>> ] [ text>> ] bi ?nth >>line-text
- dup line-text>> length >>line-length
- [ 1+ ] change-line
- 0 >>column
- drop ;
-
-: new-lexer ( text class -- lexer )
- new
- 0 >>line
- swap >>text
- dup next-line ; inline
-
-: <lexer> ( text -- lexer )
- lexer new-lexer ;
-
: location ( -- loc )
- file get lexer get lexer-line 2dup and
- [ >r source-file-path r> 2array ] [ 2drop f ] if ;
+ file get lexer get line>> 2dup and
+ [ >r path>> r> 2array ] [ 2drop f ] if ;
: save-location ( definition -- )
location remember-definition ;
-: save-class-location ( class -- )
- location remember-class ;
-
SYMBOL: parser-notes
t parser-notes set-global
@@ -43,13 +22,6 @@ t parser-notes set-global
: parser-notes? ( -- ? )
parser-notes get "quiet" get not and ;
-: file. ( file -- )
- [
- source-file-path <pathname> pprint
- ] [
- "<interactive>" write
- ] if* ":" write ;
-
: note. ( str -- )
parser-notes? [
file get file.
@@ -61,143 +33,9 @@ t parser-notes set-global
"Note: " write dup print
] when drop ;
-: skip ( i seq ? -- n )
- over >r
- [ swap CHAR: \s eq? xor ] curry find-from drop
- [ r> drop ] [ r> length ] if* ;
-
-: change-lexer-column ( lexer quot -- )
- swap
- [ dup lexer-column swap lexer-line-text rot call ] keep
- set-lexer-column ; inline
-
-GENERIC: skip-blank ( lexer -- )
-
-M: lexer skip-blank ( lexer -- )
- [ t skip ] change-lexer-column ;
-
-GENERIC: skip-word ( lexer -- )
-
-M: lexer skip-word ( lexer -- )
- [
- 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
- ] change-lexer-column ;
-
-: still-parsing? ( lexer -- ? )
- dup lexer-line swap lexer-text length <= ;
-
-: still-parsing-line? ( lexer -- ? )
- dup lexer-column swap lexer-line-length < ;
-
-: (parse-token) ( lexer -- str )
- [ lexer-column ] keep
- [ skip-word ] keep
- [ lexer-column ] keep
- lexer-line-text subseq ;
-
-: parse-token ( lexer -- str/f )
- dup still-parsing? [
- dup skip-blank
- dup still-parsing-line?
- [ (parse-token) ] [ dup next-line parse-token ] if
- ] [ drop f ] if ;
-
-: scan ( -- str/f ) lexer get parse-token ;
-
-ERROR: bad-escape ;
-
-M: bad-escape summary drop "Bad escape code" ;
-
-: escape ( escape -- ch )
- H{
- { CHAR: a CHAR: \a }
- { CHAR: e CHAR: \e }
- { CHAR: n CHAR: \n }
- { CHAR: r CHAR: \r }
- { CHAR: t CHAR: \t }
- { CHAR: s CHAR: \s }
- { CHAR: \s CHAR: \s }
- { CHAR: 0 CHAR: \0 }
- { CHAR: \\ CHAR: \\ }
- { CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
-
-SYMBOL: name>char-hook
-
-name>char-hook global [
- [ "Unicode support not available" throw ] or
-] change-at
-
-: unicode-escape ( str -- ch str' )
- "{" ?head-slice [
- CHAR: } over index cut-slice
- >r >string name>char-hook get call r>
- rest-slice
- ] [
- 6 cut-slice >r hex> r>
- ] if ;
-
-: next-escape ( str -- ch str' )
- "u" ?head-slice [
- unicode-escape
- ] [
- unclip-slice escape swap
- ] if ;
-
-: (parse-string) ( str -- m )
- dup [ "\"\\" member? ] find dup [
- >r cut-slice >r % r> rest-slice r>
- dup CHAR: " = [
- drop slice-from
- ] [
- drop next-escape >r , r> (parse-string)
- ] if
- ] [
- "Unterminated string" throw
- ] if ;
-
-: parse-string ( -- str )
- lexer get [
- [ swap tail-slice (parse-string) ] "" make swap
- ] change-lexer-column ;
-
-TUPLE: parse-error file line column line-text error ;
-
-: <parse-error> ( msg -- error )
- \ parse-error new
- file get >>file
- lexer get line>> >>line
- lexer get column>> >>column
- lexer get line-text>> >>line-text
- swap >>error ;
-
-: parse-dump ( error -- )
- {
- [ file>> file. ]
- [ line>> number>string print ]
- [ line-text>> dup string? [ print ] [ drop ] if ]
- [ column>> 0 or CHAR: \s <string> write ]
- } cleave
- "^" print ;
-
-M: parse-error error.
- [ parse-dump ] [ error>> error. ] bi ;
-
-M: parse-error summary
- error>> summary ;
-
-M: parse-error compute-restarts
- error>> compute-restarts ;
-
-M: parse-error error-help
- error>> error-help ;
-
SYMBOL: use
SYMBOL: in
-: word/vocab% ( word -- )
- "(" % dup word-vocabulary % " " % word-name % ")" % ;
-
: (use+) ( vocab -- )
vocab-words use get push ;
@@ -216,25 +54,8 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-ERROR: unexpected want got ;
-
-PREDICATE: unexpected-eof < unexpected
- unexpected-got not ;
-
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
-: unexpected-eof ( word -- * ) f unexpected ;
-
-: (parse-tokens) ( accum end -- accum )
- scan 2dup = [
- 2drop
- ] [
- [ pick push (parse-tokens) ] [ unexpected-eof ] if*
- ] if ;
-
-: parse-tokens ( end -- seq )
- 100 <vector> swap (parse-tokens) >array ;
-
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
@@ -248,18 +69,8 @@ M: no-current-vocab summary ( obj -- )
: CREATE ( -- word ) scan create-in ;
-: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
-
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-: create-class-in ( word -- word )
- current-vocab create
- dup save-class-location
- dup predicate-word dup set-word save-location ;
-
-: CREATE-CLASS ( -- word )
- scan create-class-in ;
-
: word-restarts ( possibilities -- restarts )
natural-sort [
[ "Use the word " swap summary append ] keep
@@ -296,62 +107,6 @@ M: no-word-error summary
] ?if
] when ;
-: create-method-in ( class generic -- method )
- create-method f set-word dup save-location ;
-
-: CREATE-METHOD ( -- method )
- scan-word bootstrap-word scan-word create-method-in ;
-
-: shadowed-slots ( superclass slots -- shadowed )
- >r all-slot-names r> intersect ;
-
-: check-slot-shadowing ( class superclass slots -- )
- shadowed-slots [
- [
- "Definition of slot ``" %
- %
- "'' in class ``" %
- word-name %
- "'' shadows a superclass slot" %
- ] "" make note.
- ] with each ;
-
-ERROR: invalid-slot-name name ;
-
-M: invalid-slot-name summary
- drop
- "Invalid slot name" ;
-
-: (parse-tuple-slots) ( -- )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
- scan {
- { [ dup not ] [ unexpected-eof ] }
- { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop ] }
- [ , (parse-tuple-slots) ]
- } cond ;
-
-: parse-tuple-slots ( -- seq )
- [ (parse-tuple-slots) ] { } make ;
-
-: parse-tuple-definition ( -- class superclass slots )
- CREATE-CLASS
- scan {
- { ";" [ tuple f ] }
- { "<" [ scan-word parse-tuple-slots ] }
- [ >r tuple parse-tuple-slots r> prefix ]
- } case 3dup check-slot-shadowing ;
-
-ERROR: not-in-a-method-error ;
-
-M: not-in-a-method-error summary
- drop "call-next-method can only be called in a method definition" ;
-
ERROR: staging-violation word ;
M: staging-violation summary
@@ -362,6 +117,10 @@ M: staging-violation summary
dup changed-definitions get key? [ staging-violation ] when
execute ;
+: scan-object ( -- object )
+ scan-word dup parsing-word?
+ [ V{ } clone swap execute-parsing first ] when ;
+
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
@@ -379,37 +138,12 @@ M: staging-violation summary
: parsed ( accum obj -- accum ) over push ;
-: with-parser ( lexer quot -- newquot )
- swap lexer set
- [ call >quotation ] [ <parse-error> rethrow ] recover ;
-
: (parse-lines) ( lexer -- quot )
- [ f parse-until ] with-parser ;
-
-SYMBOL: lexer-factory
-
-[ <lexer> ] lexer-factory set-global
+ [ f parse-until >quotation ] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
-! Parsing word utilities
-: parse-effect ( end -- effect )
- parse-tokens dup { "(" "((" } intersect empty? [
- { "--" } split1 dup [
- <effect>
- ] [
- "Stack effect declaration must contain --" throw
- ] if
- ] [
- "Stack effect declaration must not contain ( or ((" throw
- ] if ;
-
-ERROR: bad-number ;
-
-: parse-base ( parsed base -- parsed )
- scan swap base> [ bad-number ] unless* parsed ;
-
: parse-literal ( accum end quot -- accum )
>r parse-until r> call parsed ; inline
@@ -418,40 +152,14 @@ ERROR: bad-number ;
: (:) ( -- word def ) CREATE-WORD parse-definition ;
-SYMBOL: current-class
-SYMBOL: current-generic
-
-: with-method-definition ( quot -- parsed )
- [
- >r
- [ "method-class" word-prop current-class set ]
- [ "method-generic" word-prop current-generic set ]
- [ ] tri
- r> call
- ] with-scope ; inline
-
-: (M:) ( method def -- )
- CREATE-METHOD [ parse-definition ] with-method-definition ;
-
-: scan-object ( -- object )
- scan-word dup parsing-word?
- [ V{ } clone swap execute first ] when ;
-
-GENERIC: expected>string ( obj -- str )
-
-M: f expected>string drop "end of input" ;
-M: word expected>string word-name ;
-M: string expected>string ;
-
-M: unexpected error.
- "Expected " write
- dup unexpected-want expected>string write
- " but got " write
- unexpected-got expected>string print ;
+ERROR: bad-number ;
M: bad-number summary
drop "Bad number literal" ;
+: parse-base ( parsed base -- parsed )
+ scan swap base> [ bad-number ] unless* parsed ;
+
SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 454f148974..0577dacc85 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -75,11 +75,36 @@ M: pathname forget*
SYMBOL: file
+TUPLE: source-file-error file error ;
+
+: <source-file-error> ( msg -- error )
+ \ source-file-error new
+ file get >>file
+ swap >>error ;
+
+: file. ( file -- ) path>> <pathname> pprint ;
+
+M: source-file-error error.
+ "Error while parsing " write
+ [ file>> file. nl ] [ error>> error. ] bi ;
+
+M: source-file-error summary
+ error>> summary ;
+
+M: source-file-error compute-restarts
+ error>> compute-restarts ;
+
+M: source-file-error error-help
+ error>> error-help ;
+
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
swap source-file
dup file set
source-file-definitions old-definitions set
- [ ] [ file get rollback-source-file ] cleanup
+ [
+ file get rollback-source-file
+ <source-file-error> rethrow
+ ] recover
] with-scope ; inline
diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor
new file mode 100644
index 0000000000..0aa6d483ca
--- /dev/null
+++ b/core/strings/parser/parser-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax strings lexer ;
+IN: strings.parser
+
+HELP: bad-escape
+{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ;
+
+HELP: escape
+{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
+{ $description "Converts from a single-character escape code and the corresponding character." }
+{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
+
+HELP: parse-string
+{ $values { "str" "a new " { $link string } } }
+{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
+{ $errors "Throws an error if the string contains an invalid escape sequence." }
+$parsing-note ;
diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor
new file mode 100644
index 0000000000..08421b4a20
--- /dev/null
+++ b/core/strings/parser/parser.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel inspector assocs namespaces splitting sequences
+strings math.parser lexer ;
+IN: strings.parser
+
+ERROR: bad-escape ;
+
+M: bad-escape summary drop "Bad escape code" ;
+
+: escape ( escape -- ch )
+ H{
+ { CHAR: a CHAR: \a }
+ { CHAR: e CHAR: \e }
+ { CHAR: n CHAR: \n }
+ { CHAR: r CHAR: \r }
+ { CHAR: t CHAR: \t }
+ { CHAR: s CHAR: \s }
+ { CHAR: \s CHAR: \s }
+ { CHAR: 0 CHAR: \0 }
+ { CHAR: \\ CHAR: \\ }
+ { CHAR: \" CHAR: \" }
+ } at [ bad-escape ] unless* ;
+
+SYMBOL: name>char-hook
+
+name>char-hook global [
+ [ "Unicode support not available" throw ] or
+] change-at
+
+: unicode-escape ( str -- ch str' )
+ "{" ?head-slice [
+ CHAR: } over index cut-slice
+ >r >string name>char-hook get call r>
+ rest-slice
+ ] [
+ 6 cut-slice >r hex> r>
+ ] if ;
+
+: next-escape ( str -- ch str' )
+ "u" ?head-slice [
+ unicode-escape
+ ] [
+ unclip-slice escape swap
+ ] if ;
+
+: (parse-string) ( str -- m )
+ dup [ "\"\\" member? ] find dup [
+ >r cut-slice >r % r> rest-slice r>
+ dup CHAR: " = [
+ drop slice-from
+ ] [
+ drop next-escape >r , r> (parse-string)
+ ] if
+ ] [
+ "Unterminated string" throw
+ ] if ;
+
+: parse-string ( -- str )
+ lexer get [
+ [ swap tail-slice (parse-string) ] "" make swap
+ ] change-lexer-column ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 91a453408d..dfba35f71a 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,13 +1,14 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays byte-vectors
-definitions generic hashtables kernel math
-namespaces parser sequences strings sbufs vectors words
-quotations io assocs splitting classes.tuple generic.standard
-generic.math classes io.files vocabs float-arrays
-classes.union classes.intersection classes.mixin
-classes.predicate classes.singleton compiler.units
-combinators debugger ;
+definitions generic hashtables kernel math namespaces parser
+lexer sequences strings strings.parser sbufs vectors
+words quotations io assocs splitting classes.tuple
+generic.standard generic.math generic.parser classes io.files
+vocabs float-arrays classes.parser classes.union
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple.parser compiler.units
+combinators debugger effects.parser ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor
index 7d3ef89759..c83d4b5152 100644
--- a/extra/bitfields/bitfields.factor
+++ b/extra/bitfields/bitfields.factor
@@ -1,4 +1,4 @@
-USING: parser kernel math sequences namespaces assocs inspector
+USING: parser lexer kernel math sequences namespaces assocs inspector
words splitting math.parser arrays sequences.next mirrors
shuffle compiler.units ;
IN: bitfields
diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor
index 0476cbf18b..b46e322d7b 100755
--- a/extra/bootstrap/unicode/unicode.factor
+++ b/extra/bootstrap/unicode/unicode.factor
@@ -1,4 +1,4 @@
-USING: parser kernel namespaces ;
+USING: strings.parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case
diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index f4cfb20591..1dd1e0a264 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables compiler.units ;
+core-foundation namespaces assocs hashtables compiler.units
+lexer ;
IN: cocoa
: (remember-send) ( selector variable -- )
diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor
index b0ffb6ae54..aa8dc4f9cf 100755
--- a/extra/cpu/8080/emulator/emulator.factor
+++ b/extra/cpu/8080/emulator/emulator.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel math sequences words arrays io io.files namespaces
-math.parser assocs quotations parser parser-combinators
+math.parser assocs quotations parser lexer parser-combinators
tools.time io.encodings.binary sequences.deep symbols combinators ;
IN: cpu.8080.emulator
diff --git a/extra/editors/editors-docs.factor b/extra/editors/editors-docs.factor
index 2b9e4cc021..0f50e40eb4 100644
--- a/extra/editors/editors-docs.factor
+++ b/extra/editors/editors-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax parser vocabs.loader ;
+USING: help.markup help.syntax parser source-files vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
@@ -35,4 +35,4 @@ HELP: no-edit-hook
{ $error-description "Thrown when " { $link edit } " is called when the " { $link edit-hook } " variable is not set. See " { $link "editor" } "." } ;
HELP: :edit
-{ $description "If the most recent error was a " { $link parse-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ;
+{ $description "If the most recent error was a " { $link source-file-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ;
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index ec8313363e..29cbbca90e 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tools.crossref tools.vocabs
-io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting accessors ;
+USING: parser lexer kernel namespaces sequences definitions
+io.files inspector continuations tools.crossref tools.vocabs io
+prettyprint source-files assocs vocabs vocabs.loader io.backend
+splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
@@ -35,21 +35,27 @@ SYMBOL: edit-hook
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
-GENERIC: find-parse-error ( error -- error' )
+GENERIC: error-file ( error -- file )
-M: parse-error find-parse-error
- dup error>> find-parse-error [ ] [ ] ?if ;
+GENERIC: error-line ( error -- line )
-M: condition find-parse-error
- error>> find-parse-error ;
+M: lexer-error error-line line>> ;
-M: object find-parse-error
- drop f ;
+M: source-file-error error-file file>> path>> ;
+
+M: source-file-error error-line error>> error-line ;
+
+M: condition error-file error>> error-file ;
+
+M: condition error-line error>> error-line ;
+
+M: object error-file drop f ;
+
+M: object error-line drop f ;
: :edit ( -- )
- error get find-parse-error [
- [ file>> path>> ] [ line>> ] bi edit-location
- ] when* ;
+ error get [ error-file ] [ error-line ] bi
+ 2dup and [ edit-location ] [ 2drop ] if ;
: edit-each ( seq -- )
[
diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor
index 76615a3de5..ba0ff5bedd 100644
--- a/extra/gesture-logger/gesture-logger.factor
+++ b/extra/gesture-logger/gesture-logger.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel prettyprint ui ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors ;
+ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors
+accessors ;
IN: gesture-logger
TUPLE: gesture-logger stream ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index dfbb7a12b8..246ad56e51 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations io.streams.byte-array io.encodings.string
-classes.builtin parser ;
+classes.builtin parser lexer ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor
index 7eeb756a39..cfa576d56f 100644
--- a/extra/html/templates/chloe/syntax/syntax.factor
+++ b/extra/html/templates/chloe/syntax/syntax.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
-classes.tuple assocs splitting words arrays memoize parser
+classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
diff --git a/extra/html/templates/fhtml/fhtml.factor b/extra/html/templates/fhtml/fhtml.factor
index 74e5c37ef1..e435fdce5f 100755
--- a/extra/html/templates/fhtml/fhtml.factor
+++ b/extra/html/templates/fhtml/fhtml.factor
@@ -4,7 +4,7 @@
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting
accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8
+parser lexer io io.files io.streams.string io.encodings.utf8
html.elements
html.templates ;
IN: html.templates.fhtml
@@ -55,8 +55,8 @@ DEFER: <% delimiter
: parse-template-lines ( lines -- quot )
<template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
+ V{ } clone lexer get parse-%> f (parse-until) >quotation
+ ] with-lexer ;
: parse-template ( string -- quot )
[
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 522d0c1845..a920d4e67a 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -5,6 +5,12 @@ assocs io.sockets db db.sqlite continuations urls hashtables
accessors ;
IN: http.tests
+[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
+
+[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test
+
+[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
+
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 4001301cb1..d5712d5bab 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -211,7 +211,8 @@ TUPLE: post-data raw content content-type ;
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
- ";" split1 parse-content-type-attributes "charset" swap at ;
+ ";" split1 parse-content-type-attributes "charset" swap at
+ name>encoding over "text/" head? latin1 binary ? or ;
: read-request ( -- request )
<request>
@@ -310,7 +311,7 @@ M: response clone
dup "content-type" header [
parse-content-type
[ >>content-type ]
- [ name>encoding binary or >>content-charset ] bi*
+ [ >>content-charset ] bi*
] when* ;
: read-response ( -- response )
diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor
index 33d629b105..8f5e955998 100644
--- a/extra/io/encodings/8-bit/8-bit-docs.factor
+++ b/extra/io/encodings/8-bit/8-bit-docs.factor
@@ -24,20 +24,13 @@ ARTICLE: "io.encodings.8-bit" "8-bit encodings"
{ $subsection koi8-r }
{ $subsection windows-1252 }
{ $subsection ebcdic }
-{ $subsection mac-roman }
-"Words used in defining these"
-{ $subsection 8-bit }
-{ $subsection define-8-bit-encoding } ;
+{ $subsection mac-roman } ;
ABOUT: "io.encodings.8-bit"
HELP: 8-bit
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
-HELP: define-8-bit-encoding
-{ $values { "name" string } { "stream" "an input stream" } }
-{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
-
HELP: latin1
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
{ $see-also "encodings-introduction" } ;
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index cc6a7d093e..49eec6d652 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -4,8 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables prettyprint.sections sets
-sequences.private effects generic compiler.units accessors
-locals.backend memoize ;
+sequences.private effects effects.parser generic generic.parser
+compiler.units accessors locals.backend memoize lexer ;
IN: locals
! Inspired by
diff --git a/extra/match/match.factor b/extra/match/match.factor
index 8a174034ba..0ae285d20d 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser kernel words namespaces sequences classes.tuple
+USING: parser lexer kernel words namespaces sequences classes.tuple
combinators macros assocs math effects ;
IN: match
diff --git a/extra/money/money.factor b/extra/money/money.factor
index 54c53e9bec..ba7a0ae04f 100644
--- a/extra/money/money.factor
+++ b/extra/money/money.factor
@@ -1,4 +1,4 @@
-USING: io kernel math math.functions math.parser parser
+USING: io kernel math math.functions math.parser parser lexer
namespaces sequences splitting grouping combinators
continuations sequences.lib ;
IN: money
diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor
index 3a4dc6fefb..1b5b6f2393 100644
--- a/extra/mortar/mortar.factor
+++ b/extra/mortar/mortar.factor
@@ -1,5 +1,5 @@
-USING: kernel io parser words namespaces quotations arrays assocs sequences
+USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
splitting grouping math shuffle ;
IN: mortar
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index ce79bdaf5f..cf671c5609 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces parser kernel sequences words quotations math ;
+USING: namespaces parser lexer kernel sequences words quotations math ;
IN: multiline
: next-line-text ( -- str )
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index 8f2eee9459..fd547c8b5a 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,6 +1,6 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
-continuations ;
+continuations lexer ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index dced2e5c0c..e951ad8858 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -2,7 +2,7 @@
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces
-assocs parser sequences words quotations math.bitfields ;
+assocs parser lexer sequences words quotations math.bitfields ;
IN: openssl.libssl
diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor
index 5810a03f80..d636cc0152 100644
--- a/extra/qualified/qualified.factor
+++ b/extra/qualified/qualified.factor
@@ -1,5 +1,7 @@
-USING: kernel sequences assocs hashtables parser vocabs words namespaces
-vocabs.loader debugger sets ;
+! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs hashtables parser lexer
+vocabs words namespaces vocabs.loader debugger sets ;
IN: qualified
: define-qualified ( vocab-name prefix-name -- )
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 99e6b887c8..8872338f5d 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -1,5 +1,5 @@
USING: arrays combinators kernel lists math math.parser
-namespaces parser parser-combinators parser-combinators.simple
+namespaces parser lexer parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories ;
USE: io
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index 7d50d384e2..27e8cf1d90 100755
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators combinators.cleave combinators.lib
continuations db db.tuples db.types db.sqlite kernel math
-math.parser namespaces parser sets sequences sequences.deep
+math.parser namespaces parser lexer sets sequences sequences.deep
sequences.lib strings words destructors ;
IN: semantic-db
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
index 4c83c64641..b5e8c16b02 100755
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -1,4 +1,4 @@
-USING: kernel parser strings math namespaces sequences words io
+USING: kernel parser lexer strings math namespaces sequences words io
arrays quotations debugger kernel.private sequences.private ;
IN: state-machine
diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor
index 20cf16e640..6cf8eac6fb 100755
--- a/extra/symbols/symbols.factor
+++ b/extra/symbols/symbols.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words kernel classes.singleton ;
+USING: parser lexer sequences words kernel classes.singleton
+classes.parser ;
IN: symbols
: SYMBOLS:
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 3df5485f4e..f9b56a1d8d 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: qualified io.streams.c init fry namespaces assocs kernel
-parser tools.deploy.config vocabs sequences words words.private
-memory kernel.private continuations io prettyprint
-vocabs.loader debugger system strings sets ;
+parser lexer strings.parser tools.deploy.config vocabs sequences
+words words.private memory kernel.private continuations io
+prettyprint vocabs.loader debugger system strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor
index cf439f6407..ce717f4211 100755
--- a/extra/tuple-syntax/tuple-syntax.factor
+++ b/extra/tuple-syntax/tuple-syntax.factor
@@ -1,4 +1,4 @@
-USING: kernel sequences slots parser words classes
+USING: kernel sequences slots parser lexer words classes
slots.private mirrors ;
IN: tuple-syntax
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 72bd4e43a3..fcd3f9ab22 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
-models namespaces parser prettyprint quotations sequences
+models namespaces parser lexer prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
@@ -149,7 +149,7 @@ M: interactor dispose drop ;
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error error>> ] when
+ dup lexer-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
@@ -157,7 +157,7 @@ M: interactor dispose drop ;
drop parse-lines-interactive
] [
2nip
- dup parse-error? [
+ dup lexer-error? [
dup error>> unexpected-eof? [ drop f ] when
] when
] recover ;
diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor
index b5ba25db4e..2410779804 100755
--- a/extra/unicode/syntax/syntax.factor
+++ b/extra/unicode/syntax/syntax.factor
@@ -1,4 +1,4 @@
-USING: unicode.data kernel math sequences parser bit-arrays
+USING: unicode.data kernel math sequences parser lexer bit-arrays
namespaces sequences.private arrays quotations assocs
classes.predicate math.order ;
IN: unicode.syntax
diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor
index 38511de8e8..de661bdd9d 100644
--- a/extra/urls/urls.factor
+++ b/extra/urls/urls.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel unicode.categories combinators sequences splitting
+USING: kernel unicode.categories combinators combinators.lib
+sequences splitting
fry namespaces assocs arrays strings io.sockets
io.sockets.secure io.encodings.string io.encodings.utf8
-math math.parser accessors mirrors parser
+math math.parser accessors mirrors parser strings.parser lexer
prettyprint.backend hashtables present ;
IN: urls
@@ -11,12 +12,11 @@ IN: urls
#! In a URL, can this character be used without
#! URL-encoding?
{
- { [ dup letter? ] [ t ] }
- { [ dup LETTER? ] [ t ] }
- { [ dup digit? ] [ t ] }
- { [ dup "/_-." member? ] [ t ] }
- [ f ]
- } cond nip ; foldable
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "/_-." member? ]
+ } 1|| ; foldable
<PRIVATE
diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor
index 5942215a69..e3e13be3a9 100644
--- a/extra/vars/vars.factor
+++ b/extra/vars/vars.factor
@@ -2,7 +2,7 @@
! Thanks to Mackenzie Straight for the idea
-USING: kernel parser words namespaces sequences quotations ;
+USING: kernel parser lexer words namespaces sequences quotations ;
IN: vars
diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor
index 44bd1934f8..bf4bd618b7 100644
--- a/extra/xml/generator/generator.factor
+++ b/extra/xml/generator/generator.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel xml.data xml.utilities assocs splitting
-sequences parser quotations sequences.lib xml.utilities ;
+sequences parser lexer quotations sequences.lib xml.utilities ;
IN: xml.generator
: comment, ( string -- ) <comment> , ;
@@ -36,7 +36,7 @@ IN: xml.generator
[ \ contained*, parsed ] [
scan-word \ [ =
[ POSTPONE: [ \ tag*, parsed ]
- [ "Expected [ missing" <parse-error> throw ] if
+ [ "Expected [ missing" throw ] if
] if ;
DEFER: >>
diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor
index 87a0242412..c53bbf3b0f 100755
--- a/extra/xml/utilities/utilities.factor
+++ b/extra/xml/utilities/utilities.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences words io assocs
-quotations strings parser arrays xml.data xml.writer debugger
+quotations strings parser lexer arrays xml.data xml.writer debugger
splitting vectors sequences.deep ;
IN: xml.utilities
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
index b3adf5cb60..4c95a45832 100644
--- a/extra/xmode/loader/syntax/syntax.factor
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -1,6 +1,6 @@
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
xml.utilities xml assocs kernel combinators sequences
-math.parser namespaces parser xmode.utilities regexp io.files ;
+math.parser namespaces parser lexer xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index 2e1d0a2872..d6f9c42799 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -1,5 +1,5 @@
USING: sequences assocs kernel quotations namespaces xml.data
-xml.utilities combinators macros parser words ;
+xml.utilities combinators macros parser lexer words ;
IN: xmode.utilities
: implies >r not r> or ; inline
From b26e6b90f55f8a0d37f2b109d7813cdcfca45812 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 03:33:58 -0500
Subject: [PATCH 67/85] Code cleanup
---
extra/combinators/short-circuit/short-circuit.factor | 7 +------
extra/io/servers/connection/connection.factor | 2 +-
extra/opengl/demo-support/demo-support.factor | 2 +-
extra/opengl/shaders/shaders.factor | 2 +-
extra/regexp/regexp.factor | 5 +----
extra/unicode/breaks/breaks.factor | 3 +--
extra/unicode/collation/collation-tests.factor | 2 +-
extra/unicode/collation/collation.factor | 10 +++++-----
extra/unicode/data/data.factor | 10 +++++-----
extra/unicode/normalize/normalize.factor | 2 +-
extra/urls/urls.factor | 12 ++++++------
extra/webapps/wee-url/wee-url.factor | 2 +-
12 files changed, 25 insertions(+), 34 deletions(-)
diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor
index 1738e8ec38..3301633d7d 100644
--- a/extra/combinators/short-circuit/short-circuit.factor
+++ b/extra/combinators/short-circuit/short-circuit.factor
@@ -1,16 +1,11 @@
USING: kernel combinators quotations arrays sequences assocs
- locals shuffle macros fry newfx ;
+ locals shuffle macros fry ;
IN: combinators.short-circuit
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: short-circuit ( quots quot default -- quot )
- 1quotation -rot { } map>assoc <reversed> alist>quot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
:: n&&-rewrite ( quots N -- quot )
quots
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
index 0ff83261fb..cb26ed5722 100755
--- a/extra/io/servers/connection/connection.factor
+++ b/extra/io/servers/connection/connection.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
-quotations combinators combinators.lib logging calendar assocs
+quotations combinators logging calendar assocs
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 88531a70bc..6596948f45 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,4 +1,4 @@
-USING: arrays combinators.lib kernel math math.functions
+USING: arrays kernel math math.functions
math.order math.vectors namespaces opengl opengl.gl sequences ui
ui.gadgets ui.gestures ui.render accessors ;
IN: opengl.demo-support
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index c05e180c11..7c18736bde 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii ;
+macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 29f3c500c7..c329977875 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -21,9 +21,6 @@ SYMBOL: ignore-case?
[ [ between? ] ]
if 2curry ;
-: or-predicates ( quots -- quot )
- [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-
: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
@@ -180,7 +177,7 @@ C: <group-result> group-result
: 'positive-character-class' ( -- parser )
"]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
'character-class-term' <+> <|>
- [ or-predicates ] <@ ;
+ [ [ 1|| ] curry ] <@ ;
: 'negative-character-class' ( -- parser )
"^" token 'positive-character-class' &>
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 745fb83c3c..fe19685b53 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,8 +1,7 @@
USING: combinators.short-circuit unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
math.ranges unicode.normalize values io.encodings.ascii
-unicode.syntax unicode.data compiler.units alien.syntax sets
-combinators.lib ;
+unicode.syntax unicode.data compiler.units alien.syntax sets ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor
index 5de90d238d..5bc25de804 100755
--- a/extra/unicode/collation/collation-tests.factor
+++ b/extra/unicode/collation/collation-tests.factor
@@ -1,6 +1,6 @@
USING: io io.files splitting grouping unicode.collation
sequences kernel io.encodings.utf8 math.parser math.order
-tools.test assocs io.streams.null words combinators.lib ;
+tools.test assocs io.streams.null words ;
IN: unicode.collation.tests
: parse-test ( -- strings )
diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor
index 8deed708e6..3e239430d4 100755
--- a/extra/unicode/collation/collation.factor
+++ b/extra/unicode/collation/collation.factor
@@ -1,7 +1,7 @@
-USING: combinators.short-circuit sequences io.files io.encodings.ascii kernel values
-splitting accessors math.parser ascii io assocs strings math
-namespaces sorting combinators math.order arrays
-unicode.normalize unicode.data combinators.lib locals
+USING: combinators.short-circuit sequences io.files
+io.encodings.ascii kernel values splitting accessors math.parser
+ascii io assocs strings math namespaces sorting combinators
+math.order arrays unicode.normalize unicode.data locals
unicode.syntax macros sequences.deep words unicode.breaks
quotations ;
IN: unicode.collation
@@ -86,7 +86,7 @@ ducet insert-helpers
: add ( char -- )
dup blocked? [ 1string , ] [
dup possible-bases dup length
- [ ?combine ] 2with contains?
+ [ ?combine ] with with contains?
[ drop ] [ 1string , ] if
] if ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index b6c6292e90..f74e2e0473 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,8 +1,8 @@
-USING: combinators.short-circuit assocs math kernel sequences io.files hashtables
-quotations splitting grouping arrays math.parser hash2 math.order
-byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets
-combinators.lib combinators locals math.ranges sorting ;
+USING: combinators.short-circuit assocs math kernel sequences
+io.files hashtables quotations splitting grouping arrays
+math.parser hash2 math.order byte-arrays words namespaces words
+compiler.units parser io.encodings.ascii values interval-maps
+ascii sets combinators locals math.ranges sorting ;
IN: unicode.data
VALUE: simple-lower
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index 3b64cf577f..124840a7fb 100755
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sorting.insertion combinators.lib ;
+locals sorting.insertion ;
IN: unicode.normalize
! Conjoining Jamo behavior
diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor
index de661bdd9d..4c45164815 100644
--- a/extra/urls/urls.factor
+++ b/extra/urls/urls.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel unicode.categories combinators combinators.lib
-sequences splitting
-fry namespaces assocs arrays strings io.sockets
-io.sockets.secure io.encodings.string io.encodings.utf8
-math math.parser accessors mirrors parser strings.parser lexer
-prettyprint.backend hashtables present ;
+USING: kernel unicode.categories combinators
+combinators.short-circuit sequences splitting fry namespaces
+assocs arrays strings io.sockets io.sockets.secure
+io.encodings.string io.encodings.utf8 math math.parser accessors
+mirrors parser strings.parser lexer prettyprint.backend
+hashtables present ;
IN: urls
: url-quotable? ( ch -- ? )
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index 27187c4352..5f354b2a19 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.ranges sequences random accessors combinators.lib
+USING: math.ranges sequences random accessors
kernel namespaces fry db.types db.tuples urls validators
html.components html.forms http http.server.dispatchers furnace
furnace.actions furnace.boilerplate furnace.redirection ;
From cf345df3f561adfe207c84b1671cfbb9c1178ce7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 03:53:36 -0500
Subject: [PATCH 68/85] Bootstrap fix
---
core/lexer/lexer-docs.factor | 5 -----
extra/help/markup/markup.factor | 5 +++++
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
index b61fc82a25..a7dcb161e5 100644
--- a/core/lexer/lexer-docs.factor
+++ b/core/lexer/lexer-docs.factor
@@ -2,11 +2,6 @@ IN: lexer
USING: help.markup help.syntax kernel math sequences strings
words quotations ;
-: $parsing-note ( children -- )
- drop
- "This word should only be called from parsing words."
- $notes ;
-
HELP: lexer
{ $var-description "Stores the current " { $link lexer } " instance." }
{ $class-description "An object for tokenizing parser input. It has the following slots:"
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 32e4084150..150a66ec92 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -290,6 +290,11 @@ M: string ($instance)
: $values-x/y ( children -- )
drop { { "x" number } { "y" number } } $values ;
+: $parsing-note ( children -- )
+ drop
+ "This word should only be called from parsing words."
+ $notes ;
+
: $io-error ( children -- )
drop
"Throws an error if the I/O operation fails." $errors ;
From 666d4abaee5739c989eb870a8f99b14957766edc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 04:06:18 -0500
Subject: [PATCH 69/85] More fixes
---
core/parser/parser-tests.factor | 14 +++++++-------
core/parser/parser.factor | 8 ++------
core/prettyprint/prettyprint-tests.factor | 6 ++++--
core/source-files/source-files.factor | 5 ++---
core/vocabs/loader/loader-tests.factor | 2 +-
extra/http/http-tests.factor | 10 +++++-----
extra/opengl/shaders/shaders.factor | 2 +-
extra/unicode/collation/collation-tests.factor | 2 +-
extra/webapps/wee-url/wee-url.factor | 2 +-
9 files changed, 24 insertions(+), 27 deletions(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index eb37d556d0..074b3738ac 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -198,7 +198,7 @@ IN: parser.tests
[
"IN: parser.tests : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
- ] [ parse-error? ] must-fail-with
+ ] [ source-file-error? ] must-fail-with
[ t ] [
"y" "parser.tests" lookup >boolean
@@ -298,12 +298,12 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
@@ -313,7 +313,7 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
@@ -323,7 +323,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> no-word-error? ] must-fail-with
+ ] [ error>> error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@@ -333,12 +333,12 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> no-word-error? ] must-fail-with
+ ] [ error>> error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 44708f11f3..601245c463 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -24,12 +24,8 @@ t parser-notes set-global
: note. ( str -- )
parser-notes? [
- file get file.
- lexer get [
- lexer-line number>string print
- ] [
- nl
- ] if*
+ file get [ file. ] when*
+ lexer get line>> number>string write ": " write
"Note: " write dup print
] when drop ;
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index d5f4dd5906..9e11611f5b 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -167,9 +167,11 @@ unit-test
"another-retain-layout" another-retain-layout-test check-see
] unit-test
+DEFER: parse-error-file
+
: another-soft-break-test
{
- "USING: namespaces parser sequences ;"
+ "USING: namespaces sequences ;"
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
@@ -183,7 +185,7 @@ unit-test
: string-layout
{
- "USING: io kernel parser ;"
+ "USING: io kernel lexer ;"
"IN: prettyprint.tests"
": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write"
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 0577dacc85..2c5c19708e 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -82,11 +82,10 @@ TUPLE: source-file-error file error ;
file get >>file
swap >>error ;
-: file. ( file -- ) path>> <pathname> pprint ;
+: file. ( file -- ) path>> <pathname> . ;
M: source-file-error error.
- "Error while parsing " write
- [ file>> file. nl ] [ error>> error. ] bi ;
+ [ file>> file. ] [ error>> error. ] bi ;
M: source-file-error summary
error>> summary ;
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 45b0d6b019..5ed0b0a34c 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ error>> error>> no-word-error? ] must-fail-with
+] [ error>> error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index a920d4e67a..2a02d2cc20 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -1,8 +1,8 @@
-USING: http tools.test multiline tuple-syntax
-io.streams.string io.encodings.utf8 io.encodings.string
-kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls hashtables
-accessors ;
+USING: http tools.test multiline tuple-syntax io.streams.string
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary
+io.encodings.string kernel arrays splitting sequences assocs
+io.sockets db db.sqlite continuations urls hashtables accessors
+;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index 7c18736bde..c05e180c11 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-macros arrays io.encodings.ascii ;
+combinators.lib macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor
index 5bc25de804..d523a15ada 100755
--- a/extra/unicode/collation/collation-tests.factor
+++ b/extra/unicode/collation/collation-tests.factor
@@ -17,7 +17,7 @@ IN: unicode.collation.tests
: test-equality
{ primary= secondary= tertiary= quaternary= }
- [ execute ] 2with each ;
+ [ execute ] with with each ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index 5f354b2a19..27187c4352 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.ranges sequences random accessors
+USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
html.components html.forms http http.server.dispatchers furnace
furnace.actions furnace.boilerplate furnace.redirection ;
From c71d09ee30a8fe6682f6967371bdc30a2e371a18 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 25 Jun 2008 04:52:52 -0500
Subject: [PATCH 70/85] combinators.lib: Remove old code
---
extra/combinators/lib/lib.factor | 41 --------------------------------
1 file changed, 41 deletions(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index d9509b30f4..63e9750e8b 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -59,47 +59,6 @@ MACRO: napply ( n -- )
: assoc-map-with ( obj assoc quot -- assoc )
with* assoc-map ; inline
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! short circuiting words
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : short-circuit ( quots quot default -- quot )
-! 1quotation -rot { } map>assoc <reversed> alist>quot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! MACRO: 0&& ( quots -- quot )
-! [ '[ drop @ dup not ] [ drop f ] 2array ] map
-! { [ t ] [ ] } suffix
-! '[ f , cond ] ;
-
-! MACRO: 1&& ( quots -- quot )
-! [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
-! { [ t ] [ nip ] } suffix
-! '[ f , cond ] ;
-
-! MACRO: 2&& ( quots -- quot )
-! [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
-! { [ t ] [ 2nip ] } suffix
-! '[ f , cond ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! MACRO: 0|| ( quots -- quot )
-! [ '[ drop @ dup ] [ ] 2array ] map
-! { [ drop t ] [ f ] } suffix
-! '[ f , cond ] ;
-
-! MACRO: 1|| ( quots -- quot )
-! [ '[ drop dup @ dup ] [ nip ] 2array ] map
-! { [ drop drop t ] [ f ] } suffix
-! '[ f , cond ] ;
-
-! MACRO: 2|| ( quots -- quot )
-! [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
-! { [ drop 2drop t ] [ f ] } suffix
-! '[ f , cond ] ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From d65a76d10f4810fecf3727356056ff8b7a828074 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 15:35:14 -0500
Subject: [PATCH 71/85] Fixing builder failures
---
extra/io/encodings/8-bit/8-bit.factor | 2 +-
extra/peg/ebnf/ebnf.factor | 3 ++-
extra/persistent-vectors/persistent-vectors.factor | 2 +-
3 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor
index 30eb745314..16fe052867 100755
--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@@ -81,7 +81,7 @@ PRIVATE>
[ encoding-file parse-file 8-bit boa ]
bi*
] assoc-map
+ [ keys [ define-symbol ] each ]
[ 8-bit-encodings set-global ]
- [ [ [ ] curry define ] assoc-each ]
bi
] with-compilation-unit
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 0bf07f2687..6812aefee0 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -4,7 +4,8 @@ USING: kernel compiler.units words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
splitting accessors effects sequences.deep peg.search
- combinators.short-circuit ;
+ combinators.short-circuit lexer io.streams.string inference io
+ prettyprint combinators parser ;
IN: peg.ebnf
: rule ( name word -- parser )
diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor
index c80de3b0cd..691ebfcf4d 100644
--- a/extra/persistent-vectors/persistent-vectors.factor
+++ b/extra/persistent-vectors/persistent-vectors.factor
@@ -1,7 +1,7 @@
! Based on Clojure's PersistentVector by Rich Hickey.
USING: math accessors kernel sequences.private sequences arrays
-combinators combinators.lib parser prettyprint.backend ;
+combinators combinators.short-circuit parser prettyprint.backend ;
IN: persistent-vectors
ERROR: empty-error pvec ;
From bc5c7840165cae1fb36d7276bc11706dd4d16654 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 25 Jun 2008 15:37:01 -0500
Subject: [PATCH 72/85] Help lint fix
---
core/strings/parser/parser-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor
index 0aa6d483ca..e1c53cd87a 100644
--- a/core/strings/parser/parser-docs.factor
+++ b/core/strings/parser/parser-docs.factor
@@ -7,7 +7,7 @@ HELP: bad-escape
HELP: escape
{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
{ $description "Converts from a single-character escape code and the corresponding character." }
-{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
+{ $examples { $example "USING: kernel prettyprint strings.parser ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
HELP: parse-string
{ $values { "str" "a new " { $link string } } }
From 45bc2a0a023c2e363aa884ca4cb3a2dcacad43ad Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Wed, 25 Jun 2008 16:58:19 -0500
Subject: [PATCH 73/85] More robust server tests
---
.../distributed/distributed-tests.factor | 4 ---
.../distributed/distributed.factor | 17 ++++++------
extra/http/http-tests.factor | 23 ++++++++--------
.../connection/connection-tests.factor | 16 ++++++-----
extra/io/servers/connection/connection.factor | 27 ++++++++++++++-----
5 files changed, 49 insertions(+), 38 deletions(-)
diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor
index dc20e7ad5c..528e1956b8 100755
--- a/extra/concurrency/distributed/distributed-tests.factor
+++ b/extra/concurrency/distributed/distributed-tests.factor
@@ -13,8 +13,6 @@ concurrency.messaging continuations accessors prettyprint ;
[ ] [ test-node dup (start-node) ] unit-test
-[ ] [ 1000 sleep ] unit-test
-
[ ] [
[
receive first2 >r 3 + r> send
@@ -30,6 +28,4 @@ concurrency.messaging continuations accessors prettyprint ;
receive
] unit-test
-[ ] [ 1000 sleep ] unit-test
-
[ ] [ test-node stop-node ] unit-test
diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor
index 9ae2627505..4da079e812 100755
--- a/extra/concurrency/distributed/distributed.factor
+++ b/extra/concurrency/distributed/distributed.factor
@@ -12,16 +12,15 @@ SYMBOL: local-node
deserialize
[ first2 get-process send ] [ stop-server ] if* ;
+: <node-server> ( addrspec -- threaded-server )
+ <threaded-server>
+ swap >>insecure
+ binary >>encoding
+ "concurrency.distributed" >>name
+ [ handle-node-client ] >>handler ;
+
: (start-node) ( addrspec addrspec -- )
- local-node set-global
- [
- <threaded-server>
- swap >>insecure
- binary >>encoding
- "concurrency.distributed" >>name
- [ handle-node-client ] >>handler
- start-server
- ] curry "Distributed concurrency server" spawn drop ;
+ local-node set-global <node-server> start-server* ;
: start-node ( port -- )
host-name over <inet> (start-node) ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 2a02d2cc20..9b95dc1408 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -190,6 +190,13 @@ test-db [
init-furnace-tables
] with-db
+: test-httpd ( -- )
+ #! Return as soon as server is running.
+ <http-server>
+ 1237 >>insecure
+ f >>secure
+ start-server* ;
+
[ ] [
[
<dispatcher>
@@ -202,12 +209,10 @@ test-db [
"redirect-loop" add-responder
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
[ t ] [
"resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get nip ascii decode =
@@ -235,12 +240,10 @@ test-db [
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
@@ -262,12 +265,10 @@ test-db [
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
@@ -293,12 +294,10 @@ SYMBOL: a
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
3 a set-global
: test-a string>xml "input" tag-named "value" swap at ;
diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor
index bb87d67917..84e0d684ac 100755
--- a/extra/io/servers/connection/connection-tests.factor
+++ b/extra/io/servers/connection/connection-tests.factor
@@ -29,18 +29,22 @@ concurrency.promises io.encodings.ascii io threads calendar ;
[ ] [ <promise> "p" set ] unit-test
+[ ] [
+ <threaded-server>
+ 5 >>max-connections
+ 1237 >>insecure
+ [ "Hello world." write stop-server ] >>handler
+ "server" set
+] unit-test
+
[ ] [
[
- <threaded-server>
- 5 >>max-connections
- 1237 >>insecure
- [ "Hello world." write stop-server ] >>handler
- start-server
+ "server" get start-server
t "p" get fulfill
] in-thread
] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ "server" get wait-for-server ] unit-test
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
index cb26ed5722..fa0e2f515d 100755
--- a/extra/io/servers/connection/connection.factor
+++ b/extra/io/servers/connection/connection.factor
@@ -6,7 +6,8 @@ quotations combinators logging calendar assocs
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators
-concurrency.semaphores combinators.short-circuit ;
+concurrency.semaphores concurrency.flags
+combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
@@ -18,7 +19,8 @@ max-connections
semaphore
timeout
encoding
-handler ;
+handler
+ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@@ -31,7 +33,8 @@ handler ;
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
- [ "No handler quotation" throw ] >>handler ; inline
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready ; inline
: <threaded-server> ( -- threaded-server )
threaded-server new-threaded-server ;
@@ -86,11 +89,13 @@ M: threaded-server handle-client* handler>> call ;
if*
] [ accept-loop ] bi ; inline
-: start-accept-loop ( server -- )
+: started-accept-loop ( server -- )
+ threaded-server get
+ [ sockets>> push ] [ ready>> raise-flag ] bi ;
+
+: start-accept-loop ( addrspec -- )
threaded-server get encoding>> <server>
- [ threaded-server get sockets>> push ]
- [ [ accept-loop ] with-disposal ]
- bi ;
+ [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
\ start-accept-loop ERROR add-error-logging
@@ -115,6 +120,14 @@ PRIVATE>
] with-variable
] with-secure-context ;
+: wait-for-server ( threaded-server -- )
+ ready>> wait-for-flag ;
+
+: start-server* ( threaded-server -- )
+ [ [ start-server ] curry "Threaded server" spawn drop ]
+ [ wait-for-server ]
+ bi ;
+
: stop-server ( -- )
threaded-server get [ f ] change-sockets drop dispose-each ;
From 9d15cb9328cb1a2d046680bc9b835094a8bf00ec Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Wed, 25 Jun 2008 20:46:52 -0500
Subject: [PATCH 74/85] Remove old debugging code
---
core/compiler/compiler.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 4ee2fd5cdf..093b215013 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -46,7 +46,6 @@ SYMBOL: +failed+
] tri ;
: (compile) ( word -- )
- dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set
From 68ddfc941042c85761647da8a2b726b57e4ee1c1 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Wed, 25 Jun 2008 20:47:07 -0500
Subject: [PATCH 75/85] Fixing deployment tests
---
extra/bunny/deploy.factor | 14 ++---
extra/http/http-tests.factor | 2 +-
extra/tools/deploy/deploy-tests.factor | 35 +++++++++++
extra/tools/deploy/shaker/shaker.factor | 77 +++++++++++++++++++------
extra/tools/deploy/test/4/deploy.factor | 12 ++--
extra/tools/deploy/test/5/5.factor | 7 +++
extra/tools/deploy/test/5/deploy.factor | 15 +++++
7 files changed, 131 insertions(+), 31 deletions(-)
create mode 100644 extra/tools/deploy/test/5/5.factor
create mode 100644 extra/tools/deploy/test/5/deploy.factor
diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor
index 643737b23c..22e97b455e 100755
--- a/extra/bunny/deploy.factor
+++ b/extra/bunny/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-reflection 2 }
+ { deploy-io 3 }
+ { deploy-c-types? f }
{ deploy-random? f }
+ { deploy-ui? t }
{ deploy-name "Bunny" }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-compiler? t }
- { deploy-math? t }
- { deploy-c-types? f }
- { deploy-io 3 }
- { deploy-reflection 1 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-props? f }
}
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 9b95dc1408..7ddf6cf3aa 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -215,7 +215,7 @@ test-db [
[ t ] [
"resource:extra/http/test/foo.html" ascii file-contents
- "http://localhost:1237/nested/foo.html" http-get nip ascii decode =
+ "http://localhost:1237/nested/foo.html" http-get nip =
] unit-test
[ "http://localhost:1237/redirect-loop" http-get nip ]
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 5309784b7c..ed22902af2 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -62,3 +62,38 @@ namespaces continuations layouts accessors ;
2array try-process
] curry unit-test
] each
+
+USING: http.client furnace.actions http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+: add-quit-action
+ <action>
+ [ stop-server "Goodbye" "text/html" <content> ] >>display
+ "quit" add-responder ;
+
+: test-httpd ( -- )
+ #! Return as soon as server is running.
+ <http-server>
+ 1237 >>insecure
+ f >>secure
+ start-server* ;
+
+[ ] [
+ [
+ <dispatcher>
+ add-quit-action
+ "resource:extra/http/test" <static> >>default
+ main-responder set
+
+ test-httpd
+ ] with-scope
+] unit-test
+
+[ ] [
+ "tools.deploy.test.5" shake-and-bake
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process
+] unit-test
+
+[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index f9b56a1d8d..5a20dd8911 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -69,26 +69,69 @@ IN: tools.deploy.shaker
[ "no-def-strip" word-prop not ] filter
[ [ ] swap set-word-def ] each ;
-: strip-word-props ( retain-props words -- )
+: strip-word-props ( stripped-props words -- )
"Stripping word properties" show
[
[
word-props swap
- '[ , nip member? ] assoc-filter
+ '[ , nip member? not ] assoc-filter
f assoc-like
] keep set-word-props
] with each ;
-: retained-props ( -- seq )
+: stripped-word-props ( -- seq )
[
- "class" ,
- "metaclass" ,
- "layout" ,
- deploy-ui? get [
- "gestures" ,
- "commands" ,
- { "+nullary+" "+listener+" "+description+" }
- [ "ui.commands" lookup , ] each
+ strip-dictionary? [
+ {
+ "coercer"
+ "compiled-effect"
+ "compiled-uses"
+ "constraints"
+ "declared-effect"
+ "default-output-classes"
+ "identities"
+ "if-intrinsics"
+ "infer"
+ "inferred-effect"
+ "interval"
+ "intrinsics"
+ "loc"
+ "members"
+ "methods"
+ "combination"
+ "cannot-infer"
+ "default-method"
+ "optimizer-hooks"
+ "output-classes"
+ "participants"
+ "predicate"
+ "predicate-definition"
+ "predicating"
+ "slots"
+ "slot-names"
+ "specializer"
+ "step-into"
+ "step-into?"
+ "superclass"
+ "reading"
+ "writing"
+ "type"
+ "engines"
+ } %
+ ] when
+
+ strip-prettyprint? [
+ {
+ "delimiter"
+ "flushable"
+ "foldable"
+ "inline"
+ "lambda"
+ "macro"
+ "memo-quot"
+ "parsing"
+ "word-style"
+ } %
] when
] { } make ;
@@ -134,11 +177,11 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
- [
- io.backend:io-backend ,
- "default-buffer-size" "io.ports" lookup ,
- ] { } make
- { "alarms" "io" "tools" } strip-vocab-globals %
+ { } {
+ "alarms"
+ "tools"
+ "io.launcher"
+ } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
@@ -243,7 +286,7 @@ SYMBOL: deploy-vocab
strip-recompile-hook
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
- retained-props >r
+ stripped-word-props >r
stripped-globals strip-globals
r> strip-words ;
diff --git a/extra/tools/deploy/test/4/deploy.factor b/extra/tools/deploy/test/4/deploy.factor
index 5250ad698a..894d6aa62e 100644
--- a/extra/tools/deploy/test/4/deploy.factor
+++ b/extra/tools/deploy/test/4/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? f }
- { deploy-ui? f }
- { deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-word-defs? f }
+ { deploy-reflection 1 }
{ deploy-io 2 }
- { deploy-name "tools.deploy.test.4" }
{ deploy-c-types? f }
{ deploy-random? f }
+ { deploy-ui? f }
+ { deploy-name "tools.deploy.test.4" }
+ { deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
- { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
}
diff --git a/extra/tools/deploy/test/5/5.factor b/extra/tools/deploy/test/5/5.factor
new file mode 100644
index 0000000000..debc020d49
--- /dev/null
+++ b/extra/tools/deploy/test/5/5.factor
@@ -0,0 +1,7 @@
+IN: tools.deploy.test.5
+USING: http.client kernel ;
+
+: deploy-test-5 ( -- )
+ "http://localhost:1237/foo.html" http-get 2drop ;
+
+MAIN: deploy-test-5
diff --git a/extra/tools/deploy/test/5/deploy.factor b/extra/tools/deploy/test/5/deploy.factor
new file mode 100644
index 0000000000..87536457b0
--- /dev/null
+++ b/extra/tools/deploy/test/5/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-reflection 2 }
+ { deploy-io 3 }
+ { deploy-c-types? f }
+ { deploy-random? t }
+ { deploy-ui? f }
+ { deploy-name "tools.deploy.test.5" }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+}
From 536b849c29cfe2a5c4ac648f476fd80f55ad9ab0 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Wed, 25 Jun 2008 22:06:34 -0500
Subject: [PATCH 76/85] Tweak UI error handling for deployment
---
extra/ui/gadgets/worlds/worlds.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index 2895dd07cc..4d2f31cda5 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs continuations kernel math models
namespaces opengl sequences io combinators math.vectors
-ui.gadgets ui.gestures ui.render ui.backend inspector ;
+ui.gadgets ui.gestures ui.render ui.backend inspector
+debugger ;
IN: ui.gadgets.worlds
TUPLE: world < identity-tuple
@@ -78,7 +79,8 @@ TUPLE: world-error world ;
SYMBOL: ui-error-hook
-: ui-error ( error -- ) ui-error-hook get call ;
+: ui-error ( error -- )
+ ui-error-hook get [ call ] [ print-error ] if* ;
[ rethrow ] ui-error-hook set-global
From 92d5c683e63a1f3de9583892c879b283e0f17a68 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 26 Jun 2008 20:46:59 -0500
Subject: [PATCH 77/85] Fix :edit for nested parse errors
---
extra/editors/editors.factor | 24 +++++++++++++++++-------
1 file changed, 17 insertions(+), 7 deletions(-)
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index 29cbbca90e..78f6caf965 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -39,19 +39,29 @@ GENERIC: error-file ( error -- file )
GENERIC: error-line ( error -- line )
-M: lexer-error error-line line>> ;
+M: lexer-error error-file
+ error>> error-file ;
-M: source-file-error error-file file>> path>> ;
+M: lexer-error error-line
+ [ error>> error-line ] [ line>> ] bi or ;
-M: source-file-error error-line error>> error-line ;
+M: source-file-error error-file
+ [ error>> error-file ] [ file>> path>> ] bi or ;
-M: condition error-file error>> error-file ;
+M: source-file-error error-line
+ error>> error-line ;
-M: condition error-line error>> error-line ;
+M: condition error-file
+ error>> error-file ;
-M: object error-file drop f ;
+M: condition error-line
+ error>> error-line ;
-M: object error-line drop f ;
+M: object error-file
+ drop f ;
+
+M: object error-line
+ drop f ;
: :edit ( -- )
error get [ error-file ] [ error-line ] bi
From 3f520c3c791de021d00405569e12e01d86c84f28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 26 Jun 2008 20:47:36 -0500
Subject: [PATCH 78/85] Better error messages for when new or boa are applied
to the wrong type
---
core/classes/tuple/tuple-tests.factor | 13 ++++----
core/classes/tuple/tuple.factor | 30 +++++++++----------
core/debugger/debugger.factor | 7 +++--
core/effects/effects.factor | 4 +--
core/inference/backend/backend.factor | 2 +-
.../transforms/transforms-tests.factor | 8 ++++-
core/inference/transforms/transforms.factor | 26 ++++++++++------
core/optimizer/math/partial/partial.factor | 2 +-
core/syntax/syntax.factor | 2 +-
9 files changed, 57 insertions(+), 37 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 604914bd5c..c93bd11ffe 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order classes.private ;
+columns math.order classes.private slots.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
- size-test tuple-size =
+ size-test tuple-layout layout-size =
] unit-test
GENERIC: <yo-momma>
@@ -220,7 +220,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ error>> no-tuple-class? ] must-fail-with
+] [ error>> not-a-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
@@ -252,7 +252,7 @@ C: <laptop> laptop
test-laptop-slot-values
[ laptop ] [
- "laptop" get tuple-layout
+ "laptop" get 1 slot
dup layout-echelon swap
layout-superclasses nth
] unit-test
@@ -490,7 +490,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
@@ -595,3 +595,6 @@ GENERIC: break-me ( obj -- )
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
+
+! Insufficient type checking
+[ \ vocab tuple>array drop ] must-fail
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index b4a2302a9e..df59f34ff4 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -9,32 +9,32 @@ IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ;
-ERROR: no-tuple-class class ;
+ERROR: not-a-tuple object ;
+
+: check-tuple ( object -- tuple )
+ dup tuple? [ not-a-tuple ] unless ; inline
+
+ERROR: not-a-tuple-class class ;
+
+: check-tuple-class ( class -- class )
+ dup tuple-class? [ not-a-tuple-class ] unless ; inline
<PRIVATE
-GENERIC: tuple-layout ( object -- layout )
+: tuple-layout ( class -- layout )
+ check-tuple-class "layout" word-prop ;
-M: tuple-class tuple-layout "layout" word-prop ;
-
-M: tuple tuple-layout 1 slot ;
-
-M: tuple-layout tuple-layout ;
-
-: tuple-size tuple-layout layout-size ; inline
+: tuple-size ( tuple -- size )
+ 1 slot layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- [ tuple-size ] [ ] [ tuple-layout ] tri ;
+ check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
PRIVATE>
-: check-tuple ( class -- )
- dup tuple-class?
- [ drop ] [ no-tuple-class ] if ;
-
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
@@ -63,7 +63,7 @@ ERROR: bad-superclass class ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ tuple-layout ] bi@ eq? [
+ 2dup [ 1 slot ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index cfad144737..2ac903a39b 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -209,8 +209,11 @@ M: inconsistent-next-method summary
M: check-method summary
drop "Invalid parameters for create-method" ;
-M: no-tuple-class summary
- drop "BOA constructors can only be defined for tuple classes" ;
+M: not-a-tuple summary
+ drop "Not a tuple" ;
+
+M: not-a-tuple-class summary
+ drop "Not a tuple class" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 099260f111..d7923ad595 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ;
GENERIC: stack-effect ( word -- effect/f )
-M: symbol stack-effect drop 0 1 <effect> ;
+M: symbol stack-effect drop (( -- symbol )) ;
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
- [ in>> clone ] keep effect-out clone <effect> ;
+ [ in>> clone ] [ out>> clone ] bi <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index f8b071e803..59fbd289db 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -228,7 +228,7 @@ M: object constructor drop f ;
1 infer->r
peek-d reify-curry
1 infer-r>
- 2 1 <effect> swap #call consume/produce
+ (( obj quot -- curry )) swap #call consume/produce
] when* ;
: reify-curries ( n -- )
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index f90dd2350c..7f5f8035fb 100755
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -1,7 +1,7 @@
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
quotations inference accessors combinators words arrays
-classes ;
+classes classes.tuple ;
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
: compose-n ( quot -- ) compose-n-quot call ;
@@ -46,3 +46,9 @@ C: <color> color
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
[ fixnum instance? ] must-infer
+
+: bad-new-test ( -- obj ) V{ } new ;
+
+[ bad-new-test ] must-infer
+
+[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 5ca10c7545..8fc72b0f09 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic sets definitions ;
+inference.dataflow inference.state classes.tuple
+classes.tuple.private effects inspector hashtables classes
+generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -83,19 +84,26 @@ M: duplicated-slots-error summary
] 1 define-transform
\ boa [
- dup +inlined+ depends-on
- tuple-layout [ <tuple-boa> ] curry
+ dup tuple-class? [
+ dup +inlined+ depends-on
+ tuple-layout [ <tuple-boa> ] curry
+ ] [
+ [ not-a-tuple-class ] curry time-bomb
+ ] if
] 1 define-transform
\ new [
1 ensure-values
peek-d value? [
- pop-literal
- dup +inlined+ depends-on
- tuple-layout [ <tuple> ] curry
- swap infer-quot
+ pop-literal dup tuple-class? [
+ dup +inlined+ depends-on
+ tuple-layout [ <tuple> ] curry
+ swap infer-quot
+ ] [
+ \ not-a-tuple-class boa time-bomb drop
+ ] if
] [
- \ new 1 1 <effect> make-call-node
+ \ new (( class -- tuple )) make-call-node
] if
] "infer" set-word-prop
diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor
index 8b5e25deb1..30a726e022 100644
--- a/core/optimizer/math/partial/partial.factor
+++ b/core/optimizer/math/partial/partial.factor
@@ -59,7 +59,7 @@ PREDICATE: math-partial < word
: define-integer-op-word ( word fix-word big-word -- )
[
[ integer-op-word ] [ integer-op-quot ] 3bi
- 2 1 <effect> define-declared
+ (( x y -- z )) define-declared
]
[
[ integer-op-word ] [ 2drop ] 3bi
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index dfba35f71a..4d4b81d00e 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -168,7 +168,7 @@ IN: bootstrap.syntax
"C:" [
CREATE-WORD
- scan-word dup check-tuple
+ scan-word check-tuple-class
[ boa ] curry define-inline
] define-syntax
From fd4542a41daa83099726f6b83ff6962f7840248f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 26 Jun 2008 22:38:59 -0500
Subject: [PATCH 79/85] Fix windows bootstrap
---
extra/windows/com/syntax/syntax.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 80a4a040c4..4ce0d3a89c 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
-parser splitting grouping sequences.lib sequences namespaces
+parser lexer splitting grouping sequences.lib sequences namespaces
assocs quotations shuffle accessors words macros alien.syntax
fry arrays ;
IN: windows.com.syntax
From a25b0a8cb15d60ff3c75de89fe4d0d98a3cc874a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 27 Jun 2008 00:48:05 -0500
Subject: [PATCH 80/85] Fix &add, etc
---
core/inspector/inspector-tests.factor | 26 ++++++++++++++++++++++++++
core/inspector/inspector.factor | 11 +++++++++--
core/mirrors/mirrors.factor | 9 ++-------
3 files changed, 37 insertions(+), 9 deletions(-)
diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor
index 72c1a9a6bf..c230364342 100644
--- a/core/inspector/inspector-tests.factor
+++ b/core/inspector/inspector-tests.factor
@@ -9,3 +9,29 @@ H{ } describe
H{ } describe
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+
+[ ] [ inspector-hook get-global inspector-hook set ] unit-test
+
+[ ] [ H{ } clone inspect ] unit-test
+
+[ ] [ "a" "b" &add ] unit-test
+
+[ H{ { "b" "a" } } ] [ me get ] unit-test
+
+[ ] [ "x" 0 &put ] unit-test
+
+[ H{ { "b" "x" } } ] [ me get ] unit-test
+
+[ ] [ 0 &at ] unit-test
+
+[ "x" ] [ me get ] unit-test
+
+[ ] [ &back ] unit-test
+
+[ ] [ "y" 0 &rename ] unit-test
+
+[ H{ { "y" "x" } } ] [ me get ] unit-test
+
+[ ] [ 0 &delete ] unit-test
+
+[ H{ } ] [ me get ] unit-test
diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor
index fd4e11901a..d32f1c90cf 100755
--- a/core/inspector/inspector.factor
+++ b/core/inspector/inspector.factor
@@ -3,7 +3,7 @@
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
quotations mirrors splitting math.parser classes vocabs refs
-sets ;
+sets sorting ;
IN: inspector
GENERIC: summary ( object -- string )
@@ -78,10 +78,17 @@ SYMBOL: +editable+
: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: sorted-keys ( assoc -- alist )
+ dup mirror? [ keys ] [
+ keys
+ [ [ unparse-short ] keep ] { } map>assoc
+ sort-keys values
+ ] if ;
+
: describe* ( obj flags -- )
clone [
dup summary.
- make-mirror dup keys dup empty? [
+ make-mirror dup sorted-keys dup empty? [
2drop
] [
dup enum? [ +sequence+ on ] when
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index 0a49163075..607ba1542f 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint accessors ;
+quotations accessors ;
IN: mirrors
: all-slots ( class -- slots )
@@ -47,13 +47,8 @@ M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
-: sort-assoc ( assoc -- alist )
- >alist
- [ [ first unparse-short ] keep ] { } map>assoc
- sort-keys values ;
-
GENERIC: make-mirror ( obj -- assoc )
-M: hashtable make-mirror sort-assoc ;
+M: hashtable make-mirror ;
M: integer make-mirror drop f ;
M: array make-mirror <enum> ;
M: vector make-mirror <enum> ;
From 334d6d86c39ecb4e159067d5195aef991ac6bbd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 27 Jun 2008 01:02:11 -0500
Subject: [PATCH 81/85] Fix 'exit after last window closed' setting for
deployment
---
extra/ui/cocoa/cocoa.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 0db38e5eca..b0653ffa39 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -110,7 +110,6 @@ M: cocoa-ui-backend ui
"UI" assert.app [
[
init-clipboard
- stop-after-last-window? off
cocoa-init-hook get [ call ] when*
start-ui
finish-launching
From 38d5151322cd4434f378742f36bedfc27ffd4d73 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 27 Jun 2008 01:30:23 -0500
Subject: [PATCH 82/85] Fixing syndication to handle more RSS feeds seen in the
wild
---
extra/syndication/syndication.factor | 2 +-
extra/xml/utilities/utilities-tests.factor | 8 ++++++++
extra/xml/utilities/utilities.factor | 11 ++++++-----
3 files changed, 15 insertions(+), 6 deletions(-)
create mode 100644 extra/xml/utilities/utilities-tests.factor
diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor
index 32b3c925f3..8d4c91177a 100644
--- a/extra/syndication/syndication.factor
+++ b/extra/syndication/syndication.factor
@@ -53,7 +53,7 @@ TUPLE: entry title url description date ;
swap {
[ "title" tag-named children>string >>title ]
[ { "link" "guid" } any-tag-named children>string >url >>url ]
- [ "description" tag-named children>string >>description ]
+ [ { "description" "encoded" } any-tag-named children>string >>description ]
[
{ "date" "pubDate" } any-tag-named
children>string try-parsing-timestamp >>date
diff --git a/extra/xml/utilities/utilities-tests.factor b/extra/xml/utilities/utilities-tests.factor
new file mode 100644
index 0000000000..c150c7133d
--- /dev/null
+++ b/extra/xml/utilities/utilities-tests.factor
@@ -0,0 +1,8 @@
+IN: xml.utilities.tests
+USING: xml xml.utilities tools.test ;
+
+[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo/>" string>xml children>string ] unit-test
diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor
index c53bbf3b0f..e1875bd0c1 100755
--- a/extra/xml/utilities/utilities.factor
+++ b/extra/xml/utilities/utilities.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger
-splitting vectors sequences.deep ;
+splitting vectors sequences.deep combinators ;
IN: xml.utilities
! * System for words specialized on tag names
@@ -48,10 +48,11 @@ M: process-missing error.
standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
- tag-children
- dup [ string? ] all?
- [ "XML tag unexpectedly contains non-text children" throw ] unless
- concat ;
+ tag-children {
+ { [ dup empty? ] [ drop "" ] }
+ { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+ [ concat ]
+ } cond ;
: children-tags ( tag -- sequence )
tag-children [ tag? ] filter ;
From 89301622513e13e458316bc838a9af2a5cc3b09f Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 27 Jun 2008 01:56:53 -0500
Subject: [PATCH 83/85] Fix Windows bootstrap
---
extra/io/windows/nt/files/files.factor | 17 +++++++----------
1 file changed, 7 insertions(+), 10 deletions(-)
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index e8bdd8e4ec..2a39cea479 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -3,7 +3,7 @@ io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
kernel libc math threads system
alien.c-types alien.arrays alien.strings sequences combinators
-combinators.lib sequences.lib ascii splitting alien strings
+combinators.short-circuit ascii splitting alien strings
assocs namespaces io.files.private accessors ;
IN: io.windows.nt.files
@@ -22,21 +22,18 @@ M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
- { [ dup right-trim-separators
- { [ dup length 2 = ] [ dup second CHAR: : = ] } 0&& nip ] [
- t
- ] }
+ { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;
ERROR: not-absolute-path ;
: root-directory ( string -- string' )
- {
- [ dup length 2 >= ]
- [ dup second CHAR: : = ]
- [ dup first Letter? ]
- } 0&& [ 2 head ] [ not-absolute-path ] if ;
+ dup {
+ [ length 2 >= ]
+ [ second CHAR: : = ]
+ [ first Letter? ]
+ } 1&& [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
From 358c09d204cac20bfb1298e7f3c7611003c44751 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 27 Jun 2008 02:17:19 -0500
Subject: [PATCH 84/85] combinators.lib 3apply is kernel's tri@; remove and
update usages
---
core/kernel/kernel-tests.factor | 5 +++++
extra/combinators/lib/lib-tests.factor | 3 ---
extra/combinators/lib/lib.factor | 2 --
extra/io/windows/files/files.factor | 6 +++---
extra/io/windows/nt/backend/backend.factor | 2 +-
extra/project-euler/032/032.factor | 6 +++---
extra/project-euler/039/039.factor | 2 +-
extra/project-euler/075/075.factor | 2 +-
extra/reports/noise/noise.factor | 1 -
extra/semantic-db/semantic-db.factor | 4 ++--
extra/windows/com/syntax/syntax.factor | 2 +-
extra/windows/com/wrapper/wrapper.factor | 6 +++---
extra/windows/ole32/ole32.factor | 4 ++--
13 files changed, 22 insertions(+), 23 deletions(-)
mode change 100644 => 100755 extra/project-euler/039/039.factor
mode change 100644 => 100755 extra/project-euler/075/075.factor
mode change 100644 => 100755 extra/windows/ole32/ole32.factor
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 4b129ad59d..c5bd0615a7 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -117,3 +117,8 @@ IN: kernel.tests
: total-failure-2 [ ] (call) unimplemented ;
[ total-failure-2 ] must-fail
+
+! From combinators.lib
+[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
+[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
+[ [ sq ] tri@ ] must-infer
diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor
index 680e3220b0..e511e88fcc 100755
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@@ -10,9 +10,6 @@ IN: combinators.lib.tests
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
-[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
-[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
-[ [ sq ] 3apply ] must-infer
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 63e9750e8b..3fab4f62ae 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -36,8 +36,6 @@ MACRO: napply ( n -- )
'[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
-: 3apply ( obj obj obj quot -- ) 3 napply ; inline
-
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 6787936f96..a4aae1a005 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -4,7 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
-combinators.lib io.ports destructors accessors
+io.ports destructors accessors
math.bitfields math.bitfields.lib ;
IN: io.windows.files
@@ -216,11 +216,11 @@ M: winnt link-info ( path -- info )
"FILETIME" <c-object>
"FILETIME" <c-object>
[ GetFileTime win32-error=0/f ] 3keep
- [ FILETIME>timestamp >local-time ] 3apply
+ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ;
: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
- [ timestamp>FILETIME ] 3apply
+ [ timestamp>FILETIME ] tri@
SetFileTime win32-error=0/f ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 1a7462f304..786275c736 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -3,7 +3,7 @@ continuations destructors io io.backend io.ports io.timeouts
io.windows io.windows.files libc kernel math namespaces
sequences threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files
-io.buffers qualified ascii combinators.lib system
+io.buffers qualified ascii system
accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 68b42ca442..8a54c595a9 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -31,11 +31,11 @@ IN: project-euler.032
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
- [ string>number ] 3apply [ * ] dip = ;
+ [ string>number ] tri@ [ * ] dip = ;
: 2and3 ( n -- ? )
number>string 2 cut-slice 3 cut-slice
- [ string>number ] 3apply [ * ] dip = ;
+ [ string>number ] tri@ [ * ] dip = ;
: valid? ( n -- ? )
dup 1and4 swap 2and3 or ;
@@ -65,7 +65,7 @@ PRIVATE>
! multiplicand/multiplier/product
: mmp ( pair -- n )
- first2 2dup * [ number>string ] 3apply 3append string>number ;
+ first2 2dup * [ number>string ] tri@ 3append string>number ;
PRIVATE>
diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
old mode 100644
new mode 100755
index 9075b19324..7a9f51f1d3
--- a/extra/project-euler/039/039.factor
+++ b/extra/project-euler/039/039.factor
@@ -44,7 +44,7 @@ SYMBOL: p-count
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] [ a-transform ] [ d-transform ] tri
- [ (count-perimeters) ] 3apply
+ [ (count-perimeters) ] tri@
] [
drop
] if ;
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
old mode 100644
new mode 100755
index 453ebfa129..8e5b849de5
--- a/extra/project-euler/075/075.factor
+++ b/extra/project-euler/075/075.factor
@@ -57,7 +57,7 @@ SYMBOL: p-count
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] [ a-transform ] [ d-transform ] tri
- [ (count-perimeters) ] 3apply
+ [ (count-perimeters) ] tri@
] [
drop
] if ;
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 3537d2e719..fc8ba9821c 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -20,7 +20,6 @@ IN: reports.noise
{ 2swap 3 }
{ 2with 2 }
{ 2with* 3 }
- { 3apply 1/2 }
{ 3curry 2 }
{ 3drop 1 }
{ 3dup 2 }
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index 27e8cf1d90..89ad6fe2d0 100755
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -36,10 +36,10 @@ TUPLE: arc id subject object relation ;
: delete-arc ( arc -- ) delete-tuples ;
: create-arc ( subject object relation -- )
- [ id>> ] 3apply <arc> insert-tuple ;
+ [ id>> ] tri@ <arc> insert-tuple ;
: nodes>arc ( subject object relation -- arc )
- [ [ id>> ] [ f ] if* ] 3apply <arc> ;
+ [ [ id>> ] [ f ] if* ] tri@ <arc> ;
: select-arcs ( subject object relation -- arcs )
nodes>arc select-tuples ;
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 4ce0d3a89c..e0ea65e8be 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,4 +1,4 @@
-USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
+USING: alien alien.c-types effects kernel windows.ole32
parser lexer splitting grouping sequences.lib sequences namespaces
assocs quotations shuffle accessors words macros alien.syntax
fry arrays ;
diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor
index 6d6aa078e8..266439ad79 100755
--- a/extra/windows/com/wrapper/wrapper.factor
+++ b/extra/windows/com/wrapper/wrapper.factor
@@ -2,8 +2,8 @@ USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors fry
-math.parser ;
+math words compiler.units destructors fry
+math.parser combinators.lib ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls disposed ;
@@ -84,7 +84,7 @@ unless
swap append ;
: compile-alien-callback ( word return parameters abi quot -- alien )
- [ alien-callback ] 4 ncurry
+ '[ , , , , alien-callback ]
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
old mode 100644
new mode 100755
index a71a569f16..7daba37063
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows windows.types combinators.lib
+kernel sequences windows windows.types
math.order ;
IN: windows.ole32
@@ -132,5 +132,5 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
- [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;
+ [ StringFromGUID2 drop ] 2keep drop utf16n alien>string ;
From 9d6f21d83c1a860301f73a7d1211ece86e51a262 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 27 Jun 2008 03:03:31 -0500
Subject: [PATCH 85/85] Fix bug exposed by new/boa change
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 6812aefee0..3d48665c8c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -23,7 +23,7 @@ TUPLE: tokenizer any one many ;
: parser-tokenizer ( parser -- tokenizer )
[ 1quotation ] keep
- [ swap [ = ] curry semantic ] curry dup tokenizer boa ;
+ [ swap [ = ] curry semantic ] curry dup \ tokenizer boa ;
: rule-tokenizer ( name word -- tokenizer )
rule parser-tokenizer ;