FIX: missing calling conventions in mapped JNI functions. FIX: missing dereferencing level in JVM! struct accessing.

Red/System [
	Title:   "JVM bridge"
	Author:  "Nenad Rakocevic, Kaj de Vos"
	File: 	 %JNI.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2013 Nenad Rakocevic, Kaj de Vos. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#define func-ptr!	integer!

#define jmethodID!	int-ptr!
#define jint!		integer!
#define jobject!	int-ptr!
#define jclass!		int-ptr!
#define jstring!	int-ptr!

#define JNI-ptr!	[struct! [jni [JNI!]]]
#define JVM-ptr!	[struct! [ptr [JVM!]]]

#switch OS [
	Windows  [#define JNICALL stdcall]
	#default [#define JNICALL cdecl]
]

#define JNI_FALSE	#"^(00)"
#define JNI_TRUE  	#"^(01)"

#enum version! [
	version-1.1:	00010001h
	version-1.2:	00010002h
	version-1.4:	00010004h
	version-1.6:	00010006h
]

JVM!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]

    DestroyJavaVM 				[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
	AttachCurrentThread			[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
	DetachCurrentThread 		[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    GetEnv						[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

JNI!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]
    reserved3					[int-ptr!]

	GetVersion					[func-ptr!]
	DefineClass					[func-ptr!]
	FindClass					[function! [[JNICALL] env [JNI-ptr!] name [c-string!] return: [jclass!]]]
	FromReflectedMethod			[func-ptr!]
	FromReflectedField			[func-ptr!]
	ToReflectedMethod			[func-ptr!]
	GetSuperclass				[func-ptr!]
	IsAssignableFrom			[func-ptr!]
	ToReflectedField			[func-ptr!]

	Throw						[func-ptr!]
	ThrowNew					[func-ptr!]
	ExceptionOccurred			[func-ptr!]
	ExceptionDescribe			[func-ptr!]
	ExceptionClear				[func-ptr!]
	FatalError					[func-ptr!]

	PushLocalFrame				[func-ptr!]
	PopLocalFrame				[func-ptr!]

	NewGlobalRef				[func-ptr!]
	DeleteGlobalRef				[func-ptr!]
	DeleteLocalRef				[func-ptr!]
	IsSameObject				[func-ptr!]
	NewLocalRef					[func-ptr!]
	EnsureLocalCapacity			[func-ptr!]

	AllocObject					[func-ptr!]
	NewObject					[function! [[JNICALL] return: [jobject!]]] ;-- stack frame is manually constructed
	NewObjectV					[func-ptr!]
	NewObjectA					[func-ptr!]

	GetObjectClass				[func-ptr!]
	IsInstanceOf				[func-ptr!]
	GetMethodID					[function! [[JNICALL] env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallObjectMethod			[function! [[JNICALL variadic] return: [jobject!]]]
	CallObjectMethodV			[func-ptr!]
	CallObjectMethodA			[func-ptr!]

	CallBooleanMethod			[func-ptr!]
	CallBooleanMethodV			[func-ptr!]
	CallBooleanMethodA			[func-ptr!]

	CallByteMethod				[func-ptr!]
	CallByteMethodV				[func-ptr!]
	CallByteMethodA				[func-ptr!]

	CallCharMethod				[func-ptr!]
	CallCharMethodV				[func-ptr!]
	CallCharMethodA				[func-ptr!]

	CallShortMethod				[func-ptr!]
	CallShortMethodV			[func-ptr!]
	CallShortMethodA			[func-ptr!]

	CallIntMethod				[func-ptr!]
	CallIntMethodV				[func-ptr!]
	CallIntMethodA				[func-ptr!]

	CallLongMethod				[func-ptr!]
	CallLongMethodV				[func-ptr!]
	CallLongMethodA				[func-ptr!]

	CallFloatMethod				[func-ptr!]
	CallFloatMethodV			[func-ptr!]
	CallFloatMethodA			[func-ptr!]

	CallDoubleMethod			[func-ptr!]
	CallDoubleMethodV			[func-ptr!]
	CallDoubleMethodA			[func-ptr!]

	CallVoidMethod				[func-ptr!]
	CallVoidMethodV				[func-ptr!]
	CallVoidMethodA				[func-ptr!]

	CallNonvirtualObjectMethod	[func-ptr!]
	CallNonvirtualObjectMethodV	[func-ptr!]
	CallNonvirtualObjectMethodA	[func-ptr!]

	CallNonvirtualBooleanMethod	 [func-ptr!]
	CallNonvirtualBooleanMethodV [func-ptr!]
	CallNonvirtualBooleanMethodA [func-ptr!]

	CallNonvirtualByteMethod	[func-ptr!]
	CallNonvirtualByteMethodV	[func-ptr!]
	CallNonvirtualByteMethodA	[func-ptr!]

	CallNonvirtualCharMethod	[func-ptr!]
	CallNonvirtualCharMethodV	[func-ptr!]
	CallNonvirtualCharMethodA	[func-ptr!]

	CallNonvirtualShortMethod	[func-ptr!]
	CallNonvirtualShortMethodV	[func-ptr!]
	CallNonvirtualShortMethodA	[func-ptr!]

	CallNonvirtualIntMethod		[func-ptr!]
	CallNonvirtualIntMethodV	[func-ptr!]
	CallNonvirtualIntMethodA	[func-ptr!]

	CallNonvirtualLongMethod	[func-ptr!]
	CallNonvirtualLongMethodV	[func-ptr!]
	CallNonvirtualLongMethodA	[func-ptr!]

	CallNonvirtualFloatMethod	[func-ptr!]
	CallNonvirtualFloatMethodV	[func-ptr!]
	CallNonvirtualFloatMethodA	[func-ptr!]

	CallNonvirtualDoubleMethod	[func-ptr!]
	CallNonvirtualDoubleMethodV	[func-ptr!]
	CallNonvirtualDoubleMethodA	[func-ptr!]

	CallNonvirtualVoidMethod	[func-ptr!]
	CallNonvirtualVoidMethodV	[func-ptr!]
	CallNonvirtualVoidMethodA	[func-ptr!]

	GetFieldID					[func-ptr!]
	GetObjectField				[func-ptr!]
	GetBooleanField				[func-ptr!]
	GetByteField				[func-ptr!]
	GetCharField				[func-ptr!]
	GetShortField				[func-ptr!]
	GetIntField					[func-ptr!]
	GetLongField				[func-ptr!]
	GetFloatField				[func-ptr!]
	GetDoubleField				[func-ptr!]

	SetObjectField				[func-ptr!]
	SetBooleanField				[func-ptr!]
	SetByteField				[func-ptr!]
	SetCharField				[func-ptr!]
	SetShortField				[func-ptr!]
	SetIntField					[func-ptr!]
	SetLongField				[func-ptr!]
	SetFloatField				[func-ptr!]
	SetDoubleField				[func-ptr!]

	GetStaticMethodID			[func-ptr!]

	CallStaticObjectMethod		[func-ptr!]
	CallStaticObjectMethodV		[func-ptr!]
	CallStaticObjectMethodA		[func-ptr!]

	CallStaticBooleanMethod		[func-ptr!]
	CallStaticBooleanMethodV	[func-ptr!]
	CallStaticBooleanMethodA	[func-ptr!]

	CallStaticByteMethod		[func-ptr!]
	CallStaticByteMethodV		[func-ptr!]
	CallStaticByteMethodA		[func-ptr!]

	CallStaticCharMethod		[func-ptr!]
	CallStaticCharMethodV		[func-ptr!]
	CallStaticCharMethodA		[func-ptr!]

	CallStaticShortMethod		[func-ptr!]
	CallStaticShortMethodV		[func-ptr!]
	CallStaticShortMethodA		[func-ptr!]

	CallStaticIntMethod			[func-ptr!]
	CallStaticIntMethodV		[func-ptr!]
	CallStaticIntMethodA		[func-ptr!]

	CallStaticLongMethod		[func-ptr!]
	CallStaticLongMethodV		[func-ptr!]
	CallStaticLongMethodA		[func-ptr!]

	CallStaticFloatMethod		[func-ptr!]
	CallStaticFloatMethodV		[func-ptr!]
	CallStaticFloatMethodA		[func-ptr!]

	CallStaticDoubleMethod		[func-ptr!]
	CallStaticDoubleMethodV		[func-ptr!]
	CallStaticDoubleMethodA		[func-ptr!]

	CallStaticVoidMethod		[func-ptr!]
	CallStaticVoidMethodV		[func-ptr!]
	CallStaticVoidMethodA		[func-ptr!]

	GetStaticFieldID			[func-ptr!]
	GetStaticObjectField		[func-ptr!]
	GetStaticBooleanField		[func-ptr!]
	GetStaticByteField			[func-ptr!]
	GetStaticCharField			[func-ptr!]
	GetStaticShortField			[func-ptr!]
	GetStaticIntField			[func-ptr!]
	GetStaticLongField			[func-ptr!]
	GetStaticFloatField			[func-ptr!]
	GetStaticDoubleField		[func-ptr!]

	SetStaticObjectField		[func-ptr!]
	SetStaticBooleanField		[func-ptr!]
	SetStaticByteField			[func-ptr!]
	SetStaticCharField			[func-ptr!]
	SetStaticShortField			[func-ptr!]
	SetStaticIntField			[func-ptr!]
	SetStaticLongField			[func-ptr!]
	SetStaticFloatField			[func-ptr!]
	SetStaticDoubleField		[func-ptr!]

	NewString					[func-ptr!]
	GetStringLength				[func-ptr!]
	GetStringChars				[func-ptr!]
	ReleaseStringChars			[func-ptr!]

	NewStringUTF				[function! [[JNICALL] env [JNI-ptr!] bytes [c-string!] return: [jobject!]]]
	GetStringUTFLength			[func-ptr!]
	GetStringUTFChars			[func-ptr!]
	ReleaseStringUTFChars		[func-ptr!]

	;...
]

JNI-env!: alias JNI-ptr!

get-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetMethodID env class name sig
	if null? id [print-line ["error: GetMethodID failed on " name]]
	id
]

instantiate: func [
	[typed]
	count	[integer!]
	list	[typed-value!]
	return: [jobject!]
	/local
		env	  [JNI-env!]
		class [jclass!]
		id	  [jmethodID!]
		item  [typed-value!]
][
	env: as JNI-env! list/value
	list: list + 1
	class: as jclass! list/value
	list: list + 1
	id: get-method env class "<init>" as c-string! list/value
	list: list - 2

	while [count > 0][
		either count = 3 [
			push id										;-- replace sig by the constructor id
		][
			item: list + count - 1
			either item/type = type-c-string! [
				push env/jni/NewStringUTF env as c-string! item/value
			][
				push item/value
			]
		]
		count: count - 1
	]
	env/jni/NewObject
]

JNI_OnLoad: func [
	vm 		 [int-ptr!]
	reserved [byte-ptr!]
	return:  [integer!]
][
	version-1.6
]

#export JNICALL [
	JNI_OnLoad
]

Red/System [
	Title:   "JVM bridge"
	Author:  "Nenad Rakocevic, Kaj de Vos"
	File: 	 %JNI.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2013 Nenad Rakocevic, Kaj de Vos. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#define func-ptr!	integer!

#define jmethodID!	int-ptr!
#define jint!		integer!
#define jobject!	int-ptr!
#define jclass!		int-ptr!
#define jstring!	int-ptr!

#define JNI-ptr!	[struct! [jni [JNI!]]]

#switch OS [
	Windows  [#define JNICALL stdcall]
	#default [#define JNICALL cdecl]
]

#define JNI_FALSE	#"^(00)"
#define JNI_TRUE  	#"^(01)"

#enum version! [
	version-1.1:	00010001h
	version-1.2:	00010002h
	version-1.4:	00010004h
	version-1.6:	00010006h
]

JVM!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]

    DestroyJavaVM 				[function! [vm [JVM!] return: [jint!]]]
	AttachCurrentThread			[function! [vm [JVM!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
	DetachCurrentThread 		[function! [vm [JVM!] return: [jint!]]]
    GetEnv						[function! [vm [JVM!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [vm [JVM!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

JNI!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]
    reserved3					[int-ptr!]

	GetVersion					[func-ptr!]
	DefineClass					[func-ptr!]
	FindClass					[function! [env [JNI-ptr!] name [c-string!] return: [jclass!]]]
	FromReflectedMethod			[func-ptr!]
	FromReflectedField			[func-ptr!]
	ToReflectedMethod			[func-ptr!]
	GetSuperclass				[func-ptr!]
	IsAssignableFrom			[func-ptr!]
	ToReflectedField			[func-ptr!]

	Throw						[func-ptr!]
	ThrowNew					[func-ptr!]
	ExceptionOccurred			[func-ptr!]
	ExceptionDescribe			[func-ptr!]
	ExceptionClear				[func-ptr!]
	FatalError					[func-ptr!]

	PushLocalFrame				[func-ptr!]
	PopLocalFrame				[func-ptr!]

	NewGlobalRef				[func-ptr!]
	DeleteGlobalRef				[func-ptr!]
	DeleteLocalRef				[func-ptr!]
	IsSameObject				[func-ptr!]
	NewLocalRef					[func-ptr!]
	EnsureLocalCapacity			[func-ptr!]

	AllocObject					[func-ptr!]
	NewObject					[function! [return: [jobject!]]] ;-- stack frame is manually constructed
	NewObjectV					[func-ptr!]
	NewObjectA					[func-ptr!]

	GetObjectClass				[func-ptr!]
	IsInstanceOf				[func-ptr!]
	GetMethodID					[function! [env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallObjectMethod			[function! [[variadic]	return: [jobject!]]]
	CallObjectMethodV			[func-ptr!]
	CallObjectMethodA			[func-ptr!]

	CallBooleanMethod			[func-ptr!]
	CallBooleanMethodV			[func-ptr!]
	CallBooleanMethodA			[func-ptr!]

	CallByteMethod				[func-ptr!]
	CallByteMethodV				[func-ptr!]
	CallByteMethodA				[func-ptr!]

	CallCharMethod				[func-ptr!]
	CallCharMethodV				[func-ptr!]
	CallCharMethodA				[func-ptr!]

	CallShortMethod				[func-ptr!]
	CallShortMethodV			[func-ptr!]
	CallShortMethodA			[func-ptr!]

	CallIntMethod				[func-ptr!]
	CallIntMethodV				[func-ptr!]
	CallIntMethodA				[func-ptr!]

	CallLongMethod				[func-ptr!]
	CallLongMethodV				[func-ptr!]
	CallLongMethodA				[func-ptr!]

	CallFloatMethod				[func-ptr!]
	CallFloatMethodV			[func-ptr!]
	CallFloatMethodA			[func-ptr!]

	CallDoubleMethod			[func-ptr!]
	CallDoubleMethodV			[func-ptr!]
	CallDoubleMethodA			[func-ptr!]

	CallVoidMethod				[func-ptr!]
	CallVoidMethodV				[func-ptr!]
	CallVoidMethodA				[func-ptr!]

	CallNonvirtualObjectMethod	[func-ptr!]
	CallNonvirtualObjectMethodV	[func-ptr!]
	CallNonvirtualObjectMethodA	[func-ptr!]

	CallNonvirtualBooleanMethod	 [func-ptr!]
	CallNonvirtualBooleanMethodV [func-ptr!]
	CallNonvirtualBooleanMethodA [func-ptr!]

	CallNonvirtualByteMethod	[func-ptr!]
	CallNonvirtualByteMethodV	[func-ptr!]
	CallNonvirtualByteMethodA	[func-ptr!]

	CallNonvirtualCharMethod	[func-ptr!]
	CallNonvirtualCharMethodV	[func-ptr!]
	CallNonvirtualCharMethodA	[func-ptr!]

	CallNonvirtualShortMethod	[func-ptr!]
	CallNonvirtualShortMethodV	[func-ptr!]
	CallNonvirtualShortMethodA	[func-ptr!]

	CallNonvirtualIntMethod		[func-ptr!]
	CallNonvirtualIntMethodV	[func-ptr!]
	CallNonvirtualIntMethodA	[func-ptr!]

	CallNonvirtualLongMethod	[func-ptr!]
	CallNonvirtualLongMethodV	[func-ptr!]
	CallNonvirtualLongMethodA	[func-ptr!]

	CallNonvirtualFloatMethod	[func-ptr!]
	CallNonvirtualFloatMethodV	[func-ptr!]
	CallNonvirtualFloatMethodA	[func-ptr!]

	CallNonvirtualDoubleMethod	[func-ptr!]
	CallNonvirtualDoubleMethodV	[func-ptr!]
	CallNonvirtualDoubleMethodA	[func-ptr!]

	CallNonvirtualVoidMethod	[func-ptr!]
	CallNonvirtualVoidMethodV	[func-ptr!]
	CallNonvirtualVoidMethodA	[func-ptr!]

	GetFieldID					[func-ptr!]
	GetObjectField				[func-ptr!]
	GetBooleanField				[func-ptr!]
	GetByteField				[func-ptr!]
	GetCharField				[func-ptr!]
	GetShortField				[func-ptr!]
	GetIntField					[func-ptr!]
	GetLongField				[func-ptr!]
	GetFloatField				[func-ptr!]
	GetDoubleField				[func-ptr!]

	SetObjectField				[func-ptr!]
	SetBooleanField				[func-ptr!]
	SetByteField				[func-ptr!]
	SetCharField				[func-ptr!]
	SetShortField				[func-ptr!]
	SetIntField					[func-ptr!]
	SetLongField				[func-ptr!]
	SetFloatField				[func-ptr!]
	SetDoubleField				[func-ptr!]

	GetStaticMethodID			[func-ptr!]

	CallStaticObjectMethod		[func-ptr!]
	CallStaticObjectMethodV		[func-ptr!]
	CallStaticObjectMethodA		[func-ptr!]

	CallStaticBooleanMethod		[func-ptr!]
	CallStaticBooleanMethodV	[func-ptr!]
	CallStaticBooleanMethodA	[func-ptr!]

	CallStaticByteMethod		[func-ptr!]
	CallStaticByteMethodV		[func-ptr!]
	CallStaticByteMethodA		[func-ptr!]

	CallStaticCharMethod		[func-ptr!]
	CallStaticCharMethodV		[func-ptr!]
	CallStaticCharMethodA		[func-ptr!]

	CallStaticShortMethod		[func-ptr!]
	CallStaticShortMethodV		[func-ptr!]
	CallStaticShortMethodA		[func-ptr!]

	CallStaticIntMethod			[func-ptr!]
	CallStaticIntMethodV		[func-ptr!]
	CallStaticIntMethodA		[func-ptr!]

	CallStaticLongMethod		[func-ptr!]
	CallStaticLongMethodV		[func-ptr!]
	CallStaticLongMethodA		[func-ptr!]

	CallStaticFloatMethod		[func-ptr!]
	CallStaticFloatMethodV		[func-ptr!]
	CallStaticFloatMethodA		[func-ptr!]

	CallStaticDoubleMethod		[func-ptr!]
	CallStaticDoubleMethodV		[func-ptr!]
	CallStaticDoubleMethodA		[func-ptr!]

	CallStaticVoidMethod		[func-ptr!]
	CallStaticVoidMethodV		[func-ptr!]
	CallStaticVoidMethodA		[func-ptr!]

	GetStaticFieldID			[func-ptr!]
	GetStaticObjectField		[func-ptr!]
	GetStaticBooleanField		[func-ptr!]
	GetStaticByteField			[func-ptr!]
	GetStaticCharField			[func-ptr!]
	GetStaticShortField			[func-ptr!]
	GetStaticIntField			[func-ptr!]
	GetStaticLongField			[func-ptr!]
	GetStaticFloatField			[func-ptr!]
	GetStaticDoubleField		[func-ptr!]

	SetStaticObjectField		[func-ptr!]
	SetStaticBooleanField		[func-ptr!]
	SetStaticByteField			[func-ptr!]
	SetStaticCharField			[func-ptr!]
	SetStaticShortField			[func-ptr!]
	SetStaticIntField			[func-ptr!]
	SetStaticLongField			[func-ptr!]
	SetStaticFloatField			[func-ptr!]
	SetStaticDoubleField		[func-ptr!]

	NewString					[func-ptr!]
	GetStringLength				[func-ptr!]
	GetStringChars				[func-ptr!]
	ReleaseStringChars			[func-ptr!]

	NewStringUTF				[function! [env [JNI-ptr!] bytes [c-string!] return: [jobject!]]]
	GetStringUTFLength			[func-ptr!]
	GetStringUTFChars			[func-ptr!]
	ReleaseStringUTFChars		[func-ptr!]

	;...
]

JNI-env!: alias JNI-ptr!

get-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetMethodID env class name sig
	if null? id [print-line ["error: GetMethodID failed on " name]]
	id
]

instantiate: func [
	[typed]
	count	[integer!]
	list	[typed-value!]
	return: [jobject!]
	/local
		env	  [JNI-env!]
		class [jclass!]
		id	  [jmethodID!]
		item  [typed-value!]
][
	env: as JNI-env! list/value
	list: list + 1
	class: as jclass! list/value
	list: list + 1
	id: get-method env class "<init>" as c-string! list/value
	list: list - 2

	while [count > 0][
		either count = 3 [
			push id										;-- replace sig by the constructor id
		][
			item: list + count - 1
			either item/type = type-c-string! [
				push env/jni/NewStringUTF env as c-string! item/value
			][
				push item/value
			]
		]
		count: count - 1
	]
	env/jni/NewObject
]

JNI_OnLoad: func [
	vm 		 [int-ptr!]
	reserved [byte-ptr!]
	return:  [integer!]
][
	version-1.6
]

#export JNICALL [
	JNI_OnLoad
]


FEAT: added missing core types definitions.

Red/System [
	Title:   "Red runtime global macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macro-defs.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

;#define RED_TYPE_UNSET			0
#define RED_TYPE_NONE			1
#define RED_TYPE_LOGIC			2
#define RED_TYPE_BLOCK			3
#define RED_TYPE_PAREN			4
#define RED_TYPE_INTEGER		5
#define RED_TYPE_WORD			6
#define RED_TYPE_SET_WORD		7
#define RED_TYPE_GET_WORD		8
#define RED_TYPE_LIT_WORD		9
#define RED_TYPE_REFINEMENT		10
#define RED_TYPE_BINARY			11
#define RED_TYPE_STRING			12
#define RED_TYPE_CHAR			13
#define RED_TYPE_ISSUE			14
#define RED_TYPE_BITSET			15
#define RED_TYPE_PATH			16
#define RED_TYPE_SET_PATH		17
#define RED_TYPE_LIT_PATH		18
#define RED_TYPE_NATIVE			19
#define RED_TYPE_ACTION			20
#define RED_TYPE_FUNCTION		21
;#define RED_TYPE_FLOAT			21

Red/System [
	Title:   "Red runtime global macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macro-defs.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define RED_TYPE_UNSET			0
#define RED_TYPE_NONE			1
#define RED_TYPE_LOGIC			2
#define RED_TYPE_BLOCK			3
#define RED_TYPE_INTEGER		4
#define RED_TYPE_WORD			5
#define RED_TYPE_SET_WORD		6
#define RED_TYPE_GET_WORD		7
#define RED_TYPE_LIT_WORD		8
#define RED_TYPE_REFINEMENT		9
#define RED_TYPE_BINARY			10
#define RED_TYPE_STRING			11
#define RED_TYPE_CHAR			12
#define RED_TYPE_BITSET			13
#define RED_TYPE_PATH			14
#define RED_TYPE_SET_PATH		15
#define RED_TYPE_GET_PATH		16
#define RED_TYPE_LIT_PATH		17
#define RED_TYPE_NATIVE			18
#define RED_TYPE_ACTION			19
#define RED_TYPE_FUNCTION		20
#define RED_TYPE_FLOAT			21


FIX: added missing datatypes to predefined typesets.

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."
comma:		 #","

pi: 3.141592653589793

internal!:		make typeset! [unset!]
number!:		make typeset! [integer! float!]
scalar!:		union number! make typeset! [char!]
any-word!:		make typeset! [word! set-word! get-word! lit-word! refinement! issue!]
any-path!:		make typeset! [path! set-path! get-path! lit-path!]
any-block!:		union any-path! make typeset! [block! paren!]
any-function!:	make typeset! [native! action! op! function! routine!]
any-object!:	make typeset! [object! error!]
any-string!:	make typeset! [string! file! url!]
series!:        union any-block! any-string!
immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
any-type!:		union series! union immediate! internal!

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."
comma:		 #","

pi: 3.141592653589793

internal!:		make typeset! [unset!]
number!:		make typeset! [integer! decimal!]
scalar!:		union number! make typeset! [char!]
any-word!:		make typeset! [word! set-word! get-word! lit-word! refinement! issue!]
any-path!:		make typeset! [path! set-path! get-path! lit-path!]
any-block!:		union any-path! make typeset! [block! paren!]
any-function!:	make typeset! [native! action! op! function! routine!]
any-object!:	make typeset! [object! error!]
any-string!:	make typeset! [string! url!]
series!:        union any-block! any-string!
immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
any-type!:		union series! union immediate! internal!


FEAT: reduce HELP function spec block by using FUNCTION constructor.

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: function [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local word type info w attributes block ref
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		'else [
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: func [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributes info fun w ref block w1 w2 value
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		'else [
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]


TESTS: corrected function-test.red

TESTS: corrected function-test.red

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"
	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f

    --test-- "funfun5 #964"
        ff5-f: function [] [
            either true [
                ff5-x
             ][
                ff5-x: 0
            ]
        ]
        --assert none = ff5-f

    --test-- "funfun6 #964"
        ff6-f: function [] [
            either false [
                ff6-x
             ][
                ff6-x: 0
            ]
        ]
        --assert 0 = ff6-f

    --test-- "funfun7"
        ff7-f: function [] [
            a: 1
            b: make object! [c: 2]
            c
        ]
        --assert none = ff7-f

     --test-- "funfun8"
        ff8-i: 1
        ff8-f: function [] [
            a: 1
            b: make object! [ff8-i: 2]
            ff8-i
        ]
        --assert none = ff8-f

if system/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun9"
        ff9-f: function [] [
            a: 1
            b: function [] [c: 2]
            b
            c
        ]
        --assert none = ff9-f
]

if system/interpreted? [                          ;-- not yet supported by compiler
     --test-- "funfun10"
        ff10-i: 1
        ff10-f: function [] [
            a:
            b: function [] [ff10-i: 2]
            b
            ff10-i
        ]
        --assert none = ff10-f
]

if system/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun11"
        ff11-i: 1
        ff11-f: function [] [
            ff: func [/local ff11-i][ff11-i: 2]
            ff11-i
        ]
        --assert none = ff11-f
        --assert 1 = ff11-i
]

    --test-- "funfun12"
        ff12-i: 1
        ff12-f: function [] [
            ff: make object! [ff12-i: 2]
            ff12-i
        ]
        --assert none = ff12-f
        --assert 1 = ff12-i
 comment {                                          ####################################
    --test-- "funfun13"
        ff13-i: 1
        ff13-f: function [/extern ff13-i] [
            ff: func [/local ff13-i][ff13-i: 2]
            ff13-i: 3
        ]
        --assert 3 = ff13-f
        --assert 3 = ff13-i
                                                    ####################################}
    --test-- "funfun14"
        ff14-i: 1
        ff14-f: function [/extern ff14-i] [
            ff: make object! [ff14-i: 2]
            ff14-i: 3
        ]
        --assert 3 = ff14-f
        --assert 3 = ff14-i
 comment {                                          ####################################
    --test-- "funfun15"
        ff15-i: 1
        ff15-f: func [
            /local ff15-i
        ][
            ff15-i: 2
            ff: function [
                /extern ff15-i
            ][
                ff15-i
            ]
            ff
        ]
        --assert 2 = ff15-f
        --assert 1 = ff15-i
                                                    ####################################}

if system/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun16"
        ff16-f: function [] [
            f2: func [i] [i: 1]
            f2 i
            i
        ]
        --assert none = ff16-f
]

if system/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun17"
        ff17-i: 10
        ff17-f: function [] [
            f2: func [ff17-i] [ff17-i: 1]
            f2 ff17-i
            ff17-i
        ]
        --assert none = ff17-f
]

===end-group===

===start-group=== "functions with objects"
comment {                                          ####################################
    --test-- "fwo1 - #965"
        fwo1-f: func [
            o object!
        ][
          append o/a o/b
        ]
        fwo1-o: make object! [
            a: "hello"
            b: " world"
        ]
        --assert "hello world" = fwo1-f
                                                    ####################################}
===end-group===

~~~end-file~~~

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"

	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f

    --test-- "funfun5 #964"
        ff5-f: function [] [
            either true [
                ff5-x
             ][
                ff5-x: 0
            ]
        ]
        --assert none = ff5-f

    --test-- "funfun6 #964"
        ff6-f: function [] [
            either false [
                ff6-x
             ][
                ff6-x: 0
            ]
        ]
        --assert 0 = ff6-f

    --test-- "funfun7"
        ff7-f: function [] [
            a: 1
            b: make object! [c: 2]
            c
        ]
        --assert none = ff7-f

     --test-- "funfun8"
        ff8-i: 1
        ff8-f: function [] [
            a: 1
            b: make object! [ff8-i: 2]
            ff8-i
        ]
        --assert none = ff8-f

     --test-- "funfun9"
        ff9-f: function [] [
            a: 1
            b: function [] [c: 2]
            b
            c
        ]
        --assert none = ff9-f

     --test-- "funfun10"
        ff10-i: 1
        ff10-f: function [] [
            a:
            b: function [] [ff10-i: 2]
            b
            ff10-i
        ]
        --assert none = ff10-f

    --test-- "funfun11"
        ff11-i: 1
        ff11-f: function [] [
            ff: func [/local ff11-i][ff11-i: 2]
            ff11-i
        ]
        --assert none = ff11-f
        --assert 1 = ff11-i

    --test-- "funfun12"
        ff12-i: 1
        ff12-f: function [] [
            ff: make object! [ff12-i: 2]
            ff12-i
        ]
        --assert none = ff12-f
        --assert 1 = ff12-i
 comment {                                          ####################################
    --test-- "funfun13"
        ff13-i: 1
        ff13-f: function [/extern ff13-i] [
            ff: func [/local ff13-i][ff13-i: 2]
            ff13-i: 3
        ]
        --assert 3 = ff13-f
        --assert 3 = ff13-i
                                                    ####################################}
    --test-- "funfun14"
        ff14-i: 1
        ff14-f: function [/extern ff14-i] [
            ff: make object! [ff14-i: 2]
            ff14-i: 3
        ]
        --assert 3 = ff14-f
        --assert 3 = ff14-i
 comment {                                          ####################################
    --test-- "funfun15"
        ff15-i: 1
        ff15-f: func [
            /local ff15-i
        ][
            ff15-i: 2
            ff: function [
                /extern ff15-i
            ][
                ff15-i
            ]
            ff
        ]
        --assert 2 = ff15-f
        --assert 1 = ff15-i
                                                    ####################################}

===end-group===

~~~end-file~~~


FIX: character / used a word was parsed as a refinement (regression).

Red/System [
	Title:   "Red data loader"
	Author:  "Nenad Rakocevic"
	File: 	 %tokenizer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

tokenizer: context [

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END	["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 	["string ending delimiter not found"]
			ERR_INVALID_INTEGER	["invalid integer"]
			ERR_INVALID_PATH	["invalid path"]
		]
		print-line #"!"
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s + 1
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + 1
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in i blk
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [
			all [
				c <> null-byte
				c <> #" "
				c <> #"/"
				c <> #"^/"
				c <> #"^M"
				c <> #"^-"
				c <> #":"
				c <> #"^""
				c <> #"["
				c <> #"]"
				c <> #"("
				c <> #")"
				c <> #"{"
				c <> #"}"
				c <> #";"
			]
		][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		if all [
			type = TYPE_REFINEMENT
			s + 1 = e
		][
			type: TYPE_WORD								;-- / as word case
		]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s + 1 blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src blk
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src blk
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			block/make-in parent 4						;-- arbitrary start size
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"^"" [src: scan-string src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src blk TYPE_REFINEMENT no]
				c = #"-"  [src: scan-minus src blk]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]

Red/System [
	Title:   "Red data loader"
	Author:  "Nenad Rakocevic"
	File: 	 %tokenizer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

tokenizer: context [

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END	["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 	["string ending delimiter not found"]
			ERR_INVALID_INTEGER	["invalid integer"]
			ERR_INVALID_PATH	["invalid path"]
		]
		print-line #"!"
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s + 1
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + 1
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in i blk
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [
			all [
				c <> null-byte
				c <> #" "
				c <> #"/"
				c <> #"^/"
				c <> #"^M"
				c <> #"^-"
				c <> #":"
				c <> #"^""
				c <> #"["
				c <> #"]"
				c <> #"("
				c <> #")"
				c <> #"{"
				c <> #"}"
				c <> #";"
			]
		][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src blk
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src blk
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			block/make-in parent 4						;-- arbitrary start size
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"^"" [src: scan-string src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src + 1 blk TYPE_REFINEMENT no]
				c = #"-"  [src: scan-minus src blk]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]