FEAT: preliminary support for email! datatype (interpreter only).

build/includes.r

@@ -80,6 +80,7 @@ write %build/bin/sources.r set-cache [
 			%common.reds
 			%context.reds
 			%datatype.reds
+			%email.reds
 			%error.reds
 			%event.reds
 			%file.reds

environment/datatypes.red

@@ -58,6 +58,7 @@ event!:			make datatype! #get-definition TYPE_EVENT
 image!:			make datatype! #get-definition TYPE_IMAGE
 time!:			make datatype! #get-definition TYPE_TIME
 tag!:			make datatype! #get-definition TYPE_TAG
+email!:			make datatype! #get-definition TYPE_EMAIL
 
 none:  			make none! 0
 true:  			make logic! 1

environment/lexer.red

@@ -399,8 +399,9 @@ system/lexer: context [
 			not-file-char not-str-char not-mstr-char caret-char
 			non-printable-char integer-end ws-ASCII ws-U+2k control-char
 			four half non-zero path-end base base64-char slash-end not-url-char
+			email-end
 	][
-		cs:		[- - - - - - - - - - - - - - - - - - - - - - -]	;-- memoized bitsets
+		cs:		[- - - - - - - - - - - - - - - - - - - - - - - -]	;-- memoized bitsets
 		stack:	clear []
 		count?:	yes										;-- if TRUE, lines counter is enabled
 		old-line: line: 1
@@ -458,12 +459,13 @@ system/lexer: context [
 			]
 			cs/22: charset {[](){}":;}					;-- slash-end
 			cs/23: charset {[](){}";}					;-- not-url-char
+			cs/24: union cs/8 union cs/14 charset "<^/" ;-- email-end
 		]
 		set [
 			digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
 			not-file-char not-str-char not-mstr-char caret-char
 			non-printable-char integer-end ws-ASCII ws-U+2k control-char
-			four half non-zero path-end base64-char slash-end not-url-char
+			four half non-zero path-end base64-char slash-end not-url-char email-end
 		] cs
 
 		byte: [
@@ -582,6 +584,11 @@ system/lexer: context [
 			 s: some [#"^"" thru #"^"" | #"'" thru #"'" | e: #">" break | skip]
 			(if e/1 <> #">" [throw-error [tag! back s]])
 		]
+
+		email-rule: [
+			s: some [ahead email-end break | skip] #"@" (type: email!)
+			any [ahead email-end break | skip] e:
+		]
 
 		base-2-rule: [
 			"2#{" (type: binary!) [
@@ -861,6 +868,7 @@ system/lexer: context [
 				| tuple-rule		(store stack make-tuple s e)
 				| hexa-rule			(store stack make-hexa s e)
 				| binary-rule		if (value: make-binary s e base) (store stack value)
+				| email-rule		(store stack do make-string)
 				| integer-rule		if (value) (store stack value)
 				| float-rule		if (value: make-float s e type) (store stack value)
 				| tag-rule			(store stack do make-string)

environment/scalars.red

@@ -41,7 +41,7 @@ any-path!:		make typeset! [path! set-path! get-path! lit-path!]
 any-block!:		union any-path! any-list!
 any-function!:	make typeset! [native! action! op! function! routine!]
 any-object!:	make typeset! [object! error!]
-any-string!:	make typeset! [string! file! url! tag!]
+any-string!:	make typeset! [string! file! url! tag! email!]
 series!:		union make typeset! [binary! image! vector!] union any-block! any-string!
 immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
 default!:		union series! union immediate! union any-object! union any-function! make typeset! [map! bitset!]

runtime/datatypes/binary.reds

@@ -965,6 +965,7 @@ binary: context [
 						type = TYPE_STRING				;@@ replace with ANY_STRING?
 						type = TYPE_FILE 
 						type = TYPE_URL
+						type = TYPE_EMAIL
 						type = TYPE_TAG
 					][
 						form-buf: as red-string! cell

runtime/datatypes/email.reds

@@ -0,0 +1,150 @@
+Red/System [
+	Title:   "Email! datatype runtime functions"
+	Author:  "Nenad Rakocevic"
+	File: 	 %email.reds
+	Tabs:	 4
+	Rights:  "Copyright (C) 2016 Nenad Rakocevic. All rights reserved."
+	License: {
+		Distributed under the Boost Software License, Version 1.0.
+		See https://github.com/red/red/blob/master/red-system/runtime/BSL-License.txt
+	}
+]
+
+email: context [
+	verbose: 0
+
+	push: func [
+		email [red-email!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "email/push"]]
+
+		copy-cell as red-value! email stack/push*
+	]
+
+	;-- Actions --
+
+	make: func [
+		proto	 [red-value!]
+		spec	 [red-value!]
+		type	 [integer!]
+		return:	 [red-email!]
+		/local
+			email [red-email!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "email/make"]]
+
+		email: as red-tag! string/make proto spec type
+		set-type as red-value! email TYPE_EMAIL
+		email
+	]
+
+	mold: func [
+		email   [red-email!]
+		buffer	[red-string!]
+		only?	[logic!]
+		all?	[logic!]
+		flat?	[logic!]
+		arg		[red-value!]
+		part 	[integer!]
+		indent	[integer!]
+		return: [integer!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "email/mold"]]
+
+		url/mold as red-url! email buffer only? all? flat? arg part indent
+	]
+
+	to: func [
+		type	[red-datatype!]
+		spec	[red-integer!]
+		return: [red-value!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "email/to"]]
+
+		switch type/value [
+			TYPE_FILE
+			TYPE_STRING [
+				set-type copy-cell as cell! spec as cell! type type/value
+			]
+			default [
+				fire [TO_ERROR(script bad-to-arg) type spec]
+			]
+		]
+		as red-value! type
+	]
+
+	init: does [
+		datatype/register [
+			TYPE_EMAIL
+			TYPE_STRING
+			"email!"
+			;-- General actions --
+			:make
+			INHERIT_ACTION	;random
+			INHERIT_ACTION	;reflect
+			:to
+			INHERIT_ACTION	;form
+			:mold
+			INHERIT_ACTION	;eval-path
+			null			;set-path
+			INHERIT_ACTION	;compare
+			;-- Scalar actions --
+			null			;absolute
+			null			;add
+			null			;divide
+			null			;multiply
+			null			;negate
+			null			;power
+			null			;remainder
+			null			;round
+			null			;subtract
+			null			;even?
+			null			;odd?
+			;-- Bitwise actions --
+			null			;and~
+			null			;complement
+			null			;or~
+			null			;xor~
+			;-- Series actions --
+			null			;append
+			INHERIT_ACTION	;at
+			INHERIT_ACTION	;back
+			INHERIT_ACTION	;change
+			INHERIT_ACTION	;clear
+			INHERIT_ACTION	;copy
+			INHERIT_ACTION	;find
+			INHERIT_ACTION	;head
+			INHERIT_ACTION	;head?
+			INHERIT_ACTION	;index?
+			INHERIT_ACTION	;insert
+			INHERIT_ACTION	;length?
+			INHERIT_ACTION	;move
+			INHERIT_ACTION	;next
+			INHERIT_ACTION	;pick
+			INHERIT_ACTION	;poke
+			INHERIT_ACTION	;put
+			INHERIT_ACTION	;remove
+			INHERIT_ACTION	;reverse
+			INHERIT_ACTION	;select
+			null			;sort
+			INHERIT_ACTION	;skip
+			INHERIT_ACTION	;swap
+			INHERIT_ACTION	;tail
+			INHERIT_ACTION	;tail?
+			INHERIT_ACTION	;take
+			null			;trim
+			;-- I/O actions --
+			null			;create
+			null			;close
+			null			;delete
+			INHERIT_ACTION	;modify
+			null			;open
+			null			;open?
+			null			;query
+			null			;read
+			null			;rename
+			null			;update
+			null			;write
+		]
+	]
+]

runtime/datatypes/file.reds

@@ -186,7 +186,8 @@ file: context [
 		switch t [
 			TYPE_STRING
 			TYPE_URL
-			TYPE_TAG [
+			TYPE_TAG
+			TYPE_EMAIL [
 				set-type copy-cell as cell! spec as cell! type t
 			]
 			default  [--NOT_IMPLEMENTED--]

runtime/datatypes/string.reds

@@ -830,6 +830,7 @@ string: context [
 					type <> TYPE_STRING
 					type <> TYPE_FILE
 					type <> TYPE_URL
+					type <> TYPE_EMAIL
 				][no][
 					zero? equal? str as red-string! value op yes
 				]
@@ -1120,7 +1121,8 @@ string: context [
 		switch t [
 			TYPE_FILE
 			TYPE_URL
-			TYPE_TAG [
+			TYPE_TAG
+			TYPE_EMAIL [
 				set-type copy-cell as cell! spec as cell! type type/value
 				return as red-value! type
 			]
@@ -1400,6 +1402,7 @@ string: context [
 					TYPE_OF(str2) <> TYPE_FILE
 					TYPE_OF(str2) <> TYPE_URL
 					TYPE_OF(str2) <> TYPE_TAG
+					TYPE_OF(str2) <> TYPE_EMAIL
 				]
 			]
 		][RETURN_COMPARE_OTHER]
@@ -1631,6 +1634,7 @@ string: context [
 			type = TYPE_FILE
 			type = TYPE_URL
 			type = TYPE_TAG
+			type = TYPE_EMAIL
 		][not case?][no]
 		if same? [case?: no]
 		reverse?: any [reverse? last?]					;-- reduce both flags to one
@@ -1660,6 +1664,7 @@ string: context [
 			TYPE_FILE
 			TYPE_URL
 			TYPE_TAG
+			TYPE_EMAIL
 			TYPE_BINARY
 			TYPE_WORD [
 				either TYPE_OF(value) = TYPE_WORD [
@@ -1826,6 +1831,7 @@ string: context [
 				TYPE_FILE
 				TYPE_URL
 				TYPE_TAG
+				TYPE_EMAIL
 				TYPE_WORD
 				TYPE_BINARY [
 					either TYPE_OF(value) = TYPE_WORD [
@@ -2052,6 +2058,7 @@ string: context [
 						type = TYPE_FILE 
 						type = TYPE_URL
 						type = TYPE_TAG
+						type = TYPE_EMAIL
 					][
 						form-buf: as red-string! cell
 					][
@@ -2411,6 +2418,7 @@ string: context [
 					type = TYPE_FILE 
 					type = TYPE_URL
 					type = TYPE_TAG
+					type = TYPE_EMAIL
 				][
 					form-buf: as red-string! cell
 				][

runtime/datatypes/structures.reds

@@ -121,6 +121,13 @@ red-tag!: alias struct! [
 	cache	[c-string!]								;-- UTF-8 cached version of the string (experimental)
 ]
 
+red-email!: alias struct! [
+	header 	[integer!]								;-- cell header
+	head	[integer!]								;-- string's head index (zero-based)
+	node	[node!]									;-- series node pointer
+	cache	[c-string!]								;-- UTF-8 cached version of the string (experimental)
+]
+
 red-binary!: alias struct! [
 	header 	[integer!]								;-- cell header
 	head	[integer!]								;-- string's head index (zero-based)

runtime/hashtable.reds

@@ -174,7 +174,8 @@ _hashtable: context [
 			TYPE_STRING
 			TYPE_FILE
 			TYPE_URL
-			TYPE_TAG [
+			TYPE_TAG
+			TYPE_EMAIL [
 				hash-string as red-string! key case?
 			]
 			TYPE_CHAR
@@ -589,7 +590,8 @@ _hashtable: context [
 				TYPE_STRING
 				TYPE_FILE
 				TYPE_URL
-				TYPE_TAG	[_series/copy as red-series! key as red-series! key null yes null]
+				TYPE_TAG
+				TYPE_EMAIL	[_series/copy as red-series! key as red-series! key null yes null]
 				default		[0]
 			]
 		]

runtime/macros.reds

@@ -56,8 +56,9 @@ Red/System [
 	TYPE_SERIES											;-- 2A		42
 	TYPE_TIME											;-- 2B		43
 	TYPE_TAG											;-- 2C		44
-	TYPE_IMAGE											;-- 2D		45
-	TYPE_EVENT											;-- 2E		46
+	TYPE_EMAIL											;-- 2D		45
+	TYPE_IMAGE											;-- 2E		46
+	TYPE_EVENT											;-- 2F		47
 	TYPE_CLOSURE
 	TYPE_PORT
 
@@ -373,6 +374,7 @@ Red/System [
 		type = TYPE_BINARY
 		type = TYPE_IMAGE
 		type = TYPE_TAG
+		type = TYPE_EMAIL
 	]
 ]
 
@@ -461,6 +463,7 @@ Red/System [
 				TYPE_OF(str2) <> TYPE_FILE
 				TYPE_OF(str2) <> TYPE_URL
 				TYPE_OF(str2) <> TYPE_TAG
+				TYPE_OF(str2) <> TYPE_EMAIL
 			]
 		]
 	][RETURN_COMPARE_OTHER]