Merge pull request #771 from qtxie/remainder

FEAT: remainder action support (for integer! and char!).

boot.red

@@ -162,15 +162,27 @@ power: make action! [[
 ]
 
 remainder: make action! [[
-		"(not yet implemented)"
-		;"Returns what is left over when one value is divided by another."
-		value1 	 [number!]
-		value2 	 [number!]
-		return:  [number!]
+		"Returns what is left over when one value is divided by another."
+		value1 	 [number! char!]
+		value2 	 [number! char!]
+		return:  [number! char!]
 	]
 	#get-definition ACT_REMAINDER
 ]
 
+modulo: func [
+	"Compute a nonnegative remainder of A divided by B."
+	a		[number!]
+	b		[number!]
+	return: [number!]
+	/local r
+][
+	b: absolute b
+    all [0 > r: a % b r: r + b]
+    a: absolute a
+    either all [a + r = (a + b) 0 < r + r - b] [r - b] [r]
+]
+
 round: make action! [[
 		"(not yet implemented)"
 		;"Returns the nearest integer. Halves round up (away from zero) by default."
@@ -818,18 +830,20 @@ complement?: make native! [[
 
 ;-- #load temporary directive is used to workaround REBOL LOAD limitations on some words
 
-#load set-word! "+"  make op! :add
-#load set-word! "-"  make op! :subtract
-#load set-word! "*"  make op! :multiply
-#load set-word! "/"  make op! :divide
-#load set-word! "="  make op! :equal?
-#load set-word! "<>" make op! :not-equal?
-#load set-word! "==" make op! :strict-equal?
-#load set-word! "=?" make op! :same?
-#load set-word! "<"  make op! :lesser?
-#load set-word! ">"  make op! :greater?
-#load set-word! "<=" make op! :lesser-or-equal?
-#load set-word! ">=" make op! :greater-or-equal?
+#load set-word! "+"		make op! :add
+#load set-word! "-"		make op! :subtract
+#load set-word! "*"		make op! :multiply
+#load set-word! "/"		make op! :divide
+#load set-word! "//"	make op! :modulo
+#load set-word! "%"		make op! :remainder
+#load set-word! "="		make op! :equal?
+#load set-word! "<>"	make op! :not-equal?
+#load set-word! "=="	make op! :strict-equal?
+#load set-word! "=?"	make op! :same?
+#load set-word! "<" 	make op! :lesser?
+#load set-word! ">" 	make op! :greater?
+#load set-word! "<="	make op! :lesser-or-equal?
+#load set-word! ">="	make op! :greater-or-equal?
 
 
 ;------------------------------------------

compiler.r

@@ -1958,7 +1958,7 @@ red: context [
 		]
 	]
 
-	check-infix-operators: has [name op pos end ops][
+	check-infix-operators: has [name op pos end ops entry][
 		if infix? pc [return false]						;-- infix op already processed,
 														;-- or used in prefix mode.
 		if infix? next pc [
@@ -1981,7 +1981,14 @@ red: context [
 
 			forall ops [
 				comp-expression/no-infix				;-- fetch right operand
-				emit make-func-prefix ops/1
+				either all [
+					entry: find functions ops/1
+					entry/2/1 = 'function!
+				][
+					emit decorate-func ops/1
+				][
+					emit make-func-prefix ops/1
+				]
 				insert-lf -1
 				emit-close-frame
 				unless tail? next ops [pc: next pc]		;-- jump over op word unless last operand
@@ -2116,7 +2123,7 @@ red: context [
 				true
 			]
 			#load [										;-- temporary directive
-				change/part/only pc to do pc/2 pc/3 3 2
+				change/part/only pc to do pc/2 pc/3 3
 				comp-expression							;-- continue expression fetching
 				true
 			]

lexer.r

@@ -71,7 +71,7 @@ lexer: context [
 
 	not-word-char:  charset {/\^^,[](){}"#%$@:;}
 	not-word-1st:	union union not-word-char digit charset {'}
-	not-file-char:  charset {[](){}"%@:;}
+	not-file-char:  charset {[](){}"@:;}
 	not-str-char:   #"^""
 	not-mstr-char:  #"}"
 	caret-char:	    charset [#"^(40)" - #"^(5F)"]
@@ -176,7 +176,9 @@ lexer: context [
 	]
 
 	word-rule: 	[
-		(type: word!) s: begin-symbol-rule [
+		(type: word!)
+		#"%" ws-no-count (value: "%")				;-- special case for remainder op!
+		| s: begin-symbol-rule [
 			path-rule 								;-- path matched
 			| (value: copy/part s e)				;-- word matched
 			opt [#":" (type: set-word!)]
@@ -554,9 +556,9 @@ lexer: context [
 		]
 		new
 	]
-	
+
 	load-file: func [s [string!]][
-		either empty? s [first [///]][to file! s]
+		to file! dehex s
 	]
 
 	process: func [src [string! binary!] /local blk][

lexer.red

@@ -179,16 +179,14 @@ transcode: function [
 	]
 
 	decode-hex: [
-		set c [
-			digit 			(value: c - #"0")
-			| hexa-upper	(value: c - #"A" + 10)
-			| hexa-lower	(value: c - #"a" + 10)
-			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
-		]
+		[set c digit (value: c - #"0")]
+		|[set c hexa-upper (value: c - #"A" + 10)]
+		|[set c hexa-lower (value: c - #"a" + 10)]
+		| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
 	]
 
 	decode-2hex: [
-		decode-hex (hex: value << 4)
+		decode-hex (hex: value * 16)
 		decode-hex (hex: hex + value)
 	]
 
@@ -211,7 +209,7 @@ transcode: function [
 		cs/5:  union cs/4 cs/3							;-- hexa-char	
 		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
 		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
-		cs/8:  charset {[](){}"%@:;}					;-- not-file-char
+		cs/8:  charset {[](){}"@:;}						;-- not-file-char
 		cs/9:  #"^""									;-- not-str-char
 		cs/10: #"}"										;-- not-mstr-char
 		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
@@ -360,11 +358,12 @@ transcode: function [
 	]
 
 	word-rule: 	[
-		s: begin-symbol-rule (type: word!) [
-			path-rule 									;-- path matched
-			| opt [#":" (type: set-word!)]
-			  (trans-word last stack copy/part s e type) ;-- word or set-word matched
-		] 
+		#"%" ws-no-count (trans-word last stack "%" word!)	 ;-- special case for remainder op!
+		| s: begin-symbol-rule (type: word!) [
+				path-rule 									 ;-- path matched
+				| opt [#":" (type: set-word!)]
+				  (trans-word last stack copy/part s e type) ;-- word or set-word matched
+		  ]
 	]
 
 	get-word-rule: [
@@ -376,7 +375,7 @@ transcode: function [
 
 	lit-word-rule: [
 		#"'" (type: lit-word!) s: begin-symbol-rule [
-			path-rule (type: lit-path!)					;-- path matched
+			path-rule (type: lit-path!)					 ;-- path matched
 			| (trans-word last stack copy/part s e type) ;-- lit-word matched
 		]
 	]
@@ -471,7 +470,7 @@ transcode: function [
 			| get-word-rule
 			| slash-rule		(trans-word last stack copy/part s e word!)
 			| refinement-rule
-			| file-rule			(append last stack do process)
+			| file-rule			(append last stack value: do process)
 			| char-rule			(append last stack value)
 			| issue-rule
 			| block-rule

runtime/actions.reds

@@ -310,7 +310,18 @@ actions: context [
 		action-compare value1 value2 op
 	]
 
-	absolute*: func [][]
+	absolute*: func [
+		return:	[red-value!]
+		/local
+			action-absolute
+	][
+		#if debug? = yes [if verbose > 0 [print-line "actions/absolute"]]
+
+		action-absolute: as function! [
+			return:	[red-value!]						;-- absoluted value
+		] get-action-ptr* ACT_ABSOLUTE
+		action-absolute
+	]
 
 	add*: func [
 		return:	[red-value!]
@@ -376,7 +387,20 @@ actions: context [
 	]	
 
 	power*: func [][]
-	remainder*: func [][]
+
+	remainder*: func [
+		return:	  [red-value!]
+		/local
+			action-remainder
+	][
+		#if debug? = yes [if verbose > 0 [print-line "actions/remainder"]]
+
+		action-remainder: as function! [
+			return:	  [red-value!]
+		] get-action-ptr* ACT_REMAINDER
+		action-remainder
+	]
+
 	round*: func [][]
 
 	subtract*: func [
@@ -981,13 +1005,13 @@ actions: context [
 			null			;set-path
 			:compare
 			;-- Scalar actions --
-			null			;absolute
+			:absolute*
 			:add*
 			:divide*
 			:multiply*
 			:negate*
 			null			;power
-			null			;remainder
+			:remainder*
 			null			;round
 			:subtract*
 			:even?*

runtime/datatypes/char.reds

@@ -165,6 +165,17 @@ char: context [
 		as red-value! char 
 	]
 
+	remainder: func [
+		return:  [red-value!]
+		/local
+			char [red-char!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "char/remainder"]]
+		char: as red-char! integer/do-math OP_REM
+		char/header: TYPE_CHAR
+		as red-value! char
+	]
+
 	subtract: func [
 		return:  [red-value!]
 		/local
@@ -198,7 +209,7 @@ char: context [
 			:multiply
 			null			;negate
 			null			;power
-			null			;remainder
+			:remainder
 			null			;round
 			:subtract
 			null			;even?

runtime/datatypes/integer.reds

@@ -109,6 +109,7 @@ integer: context [
 			OP_SUB [left/value - right/value]
 			OP_MUL [left/value * right/value]
 			OP_DIV [left/value / right/value]
+			OP_REM [left/value % right/value]
 		]
 		left
 	]
@@ -236,7 +237,23 @@ integer: context [
 		int/value: not int/value
 		as red-value! int
 	]
-
+
+	remainder: func [return: [red-value!]][
+		#if debug? = yes [if verbose > 0 [print-line "integer/remainder"]]
+		as red-value! do-math OP_REM
+	]
+
+	absolute: func [
+		return: [red-integer!]
+		/local
+			int [red-integer!]
+	][
+		#if debug? = yes [if verbose > 0 [print-line "integer/absolute"]]
+		int: as red-integer! stack/arguments
+		if negative? int/value [int/value: 0 - int/value]
+		int 											;-- re-use argument slot for return value
+	]
+
 	add: func [return: [red-value!]][
 		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
 		as red-value! do-math OP_ADD
@@ -297,13 +314,13 @@ integer: context [
 			null			;set-path
 			:compare
 			;-- Scalar actions --
-			null			;absolute
+			:absolute
 			:add
 			:divide
 			:multiply
 			:negate
 			null			;power
-			null			;remainder
+			:remainder
 			null			;round
 			:subtract
 			:even?

runtime/datatypes/op.reds

@@ -65,6 +65,9 @@ op: context [
 			]
 			TYPE_FUNCTION [
 				fun: as red-function! spec
+				s: as series! fun/more/value
+				native: as red-native! s/offset + 2
+				code: native/code
 				fun/spec
 			]
 		]

runtime/macros.reds

@@ -182,6 +182,7 @@ Red/System [
 	OP_SUB
 	OP_MUL
 	OP_DIV
+	OP_REM
 ]
 
 #enum comparison-op! [

system/compiler.r

@@ -81,7 +81,7 @@ system-dialect: make-profilable context [
 
 		comparison-op: [= <> < > <= >=]
 
-		functions: to-hash [
+		functions: to-hash compose [
 		;--Name--Arity--Type----Cc--Specs--		   Cc = Calling convention
 			+		[2	op		- [a [poly!]   b [poly!]   return: [poly!]]]
 			-		[2	op		- [a [poly!]   b [poly!]   return: [poly!]]]
@@ -91,7 +91,7 @@ system-dialect: make-profilable context [
 			or		[2	op		- [a [bit-set!] b [bit-set!] return: [bit-set!]]]
 			xor		[2	op		- [a [bit-set!] b [bit-set!] return: [bit-set!]]]
 			//		[2	op		- [a [any-number!] b [any-number!] return: [any-number!]]]		;-- modulo
-			///		[2	op		- [a [any-number!] b [any-number!] return: [any-number!]]]		;-- remainder (real syntax: %)
+			(to-word "%")		[2	op		- [a [any-number!] b [any-number!] return: [any-number!]]]		;-- remainder (real syntax: %)
 			>>		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift left signed
 			<<		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift right signed
 			-**		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift right unsigned

system/targets/ARM.r

@@ -1577,8 +1577,8 @@ make-profilable make target-class [
 		/local mod? scale c type arg2 op-poly
 	][
 		;-- r0 = a, r1 = b
-		if find [// ///] name [						;-- work around unaccepted '// and '///
-			mod?: select [// mod /// rem] name		;-- convert operators to words (easier to handle)
+		if find mod-rem-op name [					;-- work around unaccepted '// and '%
+			mod?: select mod-rem-func name			;-- convert operators to words (easier to handle)
 			name: first [/]							;-- work around unaccepted '/ 
 		]
 		arg2: compiler/unbox args/2
@@ -1904,7 +1904,7 @@ make-profilable make target-class [
 			]
 			find math-op name [
 				either width = 8 [
-					either find [/// //] name [
+					either find mod-rem-op name [
 						emit-i32 #{ee802b01}		;-- FDIVD  d2, d0, d1
 						emit-i32 #{eebd4bc2}		;-- FTOSID s8, d2		; round towards 0
 						emit-i32 #{eeb02b40}		;-- FCPYD  d2, d0		; d2 = dividend
@@ -1920,7 +1920,7 @@ make-profilable make target-class [
 					]
 					emit-i32 #{ec510b12}			;-- FMRRD r0, r1, d2	; move result to CPU
 				][
-					either find [/// //] name [
+					either find mod-rem-op name [
 						emit-i32 #{ee802a01}		;-- FDIVS  s4, s0, s2
 						emit-i32 #{eebd4ac2}		;-- FTOSIS s8, s4		; round towards 0
 						emit-i32 #{eeb02a40}		;-- FCPYS  s4, s0		; s4 = dividend