├── docs ├── last-file.tmp └── template.html ├── path-to-red.txt ├── README ├── ShareAnalysis ├── share-analysis.red └── share-analysis-test.red ├── LibTom ├── Tests │ ├── mp-zero-group.reds │ ├── mp-init-group.reds │ ├── mp-init-size-group.reds │ ├── mp-set-group.reds │ ├── mp-clear-group.reds │ ├── LTM-clear-test.reds │ ├── LTM-copy-test.reds │ ├── LTM-div-2d-test.reds │ ├── LTM-mod-2d-test.reds │ ├── mp-s-mul-digs-group.reds │ ├── mp-set-int-group.reds │ ├── mp-grow-group.reds │ ├── mp-init-multi-group.reds │ ├── mp-copy-group.reds │ ├── mp-copy-init-group.reds │ ├── mp-abs-group.reds │ ├── mp-rshd-group.reds │ ├── mp-lshd-group.reds │ ├── mp-clamp-group.reds │ ├── libtommaths-test.reds │ ├── mp-neg-group.reds │ ├── mp-mod-2d-group.reds │ ├── mp-lshb-group.reds │ ├── mp-compare-group.reds │ ├── mp-div-2d-group.reds │ └── mp-div-2-group.reds ├── LTM-zero.reds ├── LTM-abs.reds ├── LTM-clamp.reds ├── LTM-copy-init.reds ├── LTM-cmp.reds ├── LTM-negate.reds ├── LTM-clear.reds ├── LTM-init.reds ├── LTM-init-size.reds ├── LTM-set.reds ├── LTM-cmp-mag.reds ├── libtommaths.reds ├── LTM-copy.reds ├── LTM-grow.reds ├── LTM-rshd.reds ├── LTM-add.reds ├── LTM-lshd.reds ├── LTM-init-multi.reds ├── LTM-s-mul-digs.reds ├── LTM-mod-2d.reds ├── LTM-set-int.reds ├── LTM-div-2.reds ├── LTM-sub.reds ├── LTM-mul-2.reds ├── libtommaths.def ├── LTM-div-2d.reds ├── LTM-s-sub.reds ├── LTM-mul-2d.reds └── LTM-s-add.reds ├── DateTime ├── Tests │ ├── store-int-test.reds │ ├── leapyear-test.reds │ ├── date-time-test.reds │ ├── now-test.reds │ ├── year-as-days-test.reds │ ├── UTC-test.reds │ ├── duration-difference-test.reds │ ├── later-test.reds │ ├── equal-test.reds │ ├── load-date-test.reds │ ├── date-difference-test.reds │ └── days-in-year-todate-test.reds ├── PWAW-DT-push-month.reds ├── PWAW-DT-push-two-digits.reds ├── PWAW-DT-leapyear.reds ├── PWAW-DT-duration-def.reds ├── PWAW-DT-store-int.reds ├── PWAW-DT-year-as-days.reds ├── PWAW-DT-date-def.reds ├── PWAW-DT-equal.reds ├── PWAW-DT-date-time.reds ├── PWAW-DT-days-in-year-todate.reds ├── PWAW-DT-date-to-days.reds ├── PWAW-DT-later.reds ├── PWAW-DT-duration-difference.reds ├── PWAW-DT-UTC.reds ├── PWAW-DT-date-difference.reds ├── PWAW-DT-days-to-date.reds ├── PWAW-DT-date-time-libc.reds └── PWAW-DT-mold-date.reds ├── Core ├── Tests │ ├── core-test.reds │ ├── str-init-test.reds │ ├── str-equal-test.reds │ ├── str-copy-test.reds │ ├── substr-test.reds │ ├── load-int-test.reds │ ├── str-int-test.reds │ └── mold-int-test.reds ├── PWAW-C-core.reds ├── PWAW-C-str-init.reds ├── PWAW-C-str-copy.reds ├── PWAW-C-str-equal.reds ├── PWAW-C-substr.reds ├── PWAW-C-load-int.reds ├── PWAW-C-mold-int.reds └── PWAW-C-str-int.reds ├── I64 ├── PWAW-I64-negate.reds ├── Tests │ ├── int64-test.reds │ ├── greater-test.reds │ ├── mul-test.reds │ ├── div-test.reds │ ├── negate-test.reds │ ├── shift-right-test.reds │ ├── sub-test.reds │ ├── abs-add-test.reds │ └── add-test.reds ├── PWAW-I64-int64.reds ├── PWAW-I64-greater.reds ├── PWAW-I64-abs-add.reds ├── PWAW-I64-abs-sub.reds ├── PWAW-I64-shift-right.reds ├── PWAW-I64-shift-left.reds ├── PWAW-I64-abs-mul.reds ├── PWAW-I64-int64-def.reds ├── PWAW-I64-mul.reds ├── PWAW-I64-div.reds ├── PWAW-I64-add.reds ├── PWAW-I64-sub.reds └── README.md ├── run-test.rb └── UTF8 ├── utf8.reds ├── string-c-string.reds ├── ucs4-utf8.reds └── Tests └── string-c-string-test.red /docs/last-file.tmp: -------------------------------------------------------------------------------- 1 | %PWAW-Libs.md2 -------------------------------------------------------------------------------- /path-to-red.txt: -------------------------------------------------------------------------------- 1 | /Users/peter/VMShare/Languages/Red/ -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | WARNING: These libraries are deprecated and have been archived. 2 | -------------------------------------------------------------------------------- /ShareAnalysis/share-analysis.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Share Analysis" 3 | Author: "Peter W A Wood" 4 | File: %share-analysis.red 5 | Purpose: "A simple company analysis calculator" 6 | Tabs: 4 7 | 8 | Rights: "Copyright (C) 2016 Peter W A Wood. All rights reserved." 9 | License: { 10 | Distributed under the Boost Software License, Version 1.0. 11 | See https://github.com/red/red/blob/master/BSL-License.txt 12 | } 13 | ] 14 | 15 | do %share-analysis-core.red 16 | do %share-analysis-view.red 17 | view co-win -------------------------------------------------------------------------------- /LibTom/Tests/mp-zero-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-zero" 4 | 5 | --test-- "mz1" 6 | mz1-mp-int1: declare LTM-int! 7 | response: LTM-init mz1-mp-int1 8 | --assert response = LTM-OKAY 9 | mz1-mp-int1/mp-digit/value: #"^(21)" 10 | mz1-mp-int1/sign: LTM-NEG 11 | response: LTM-zero mz1-mp-int1 12 | --assert response = LTM-OKAY 13 | --assert mz1-mp-int1/used = 0 14 | --assert mz1-mp-int1/sign = LTM-ZPOS 15 | --assert mz1-mp-int1/alloc = LTM-PREC 16 | --assert mz1-mp-int1/mp-digit/value = #"^(00)" 17 | 18 | ===end-group=== 19 | -------------------------------------------------------------------------------- /DateTime/Tests/store-int-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - store-int test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2012-2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "store-int" 12 | 13 | --test-- "si-1" 14 | i: 0 15 | --assert 0 = PWAW-DT-store-int "1" :i 16 | --assert i = 1 17 | 18 | ~~~end-file~~~ 19 | -------------------------------------------------------------------------------- /Core/Tests/core-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - test script" 3 | Author: "Peter W A Wood" 4 | File: %core-test.reds 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | #include %load-int-test.reds 13 | #include %mold-int-test.reds 14 | #include %str-copy-test.reds 15 | #include %str-equal-test.reds 16 | #include %substr-test.reds 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-push-month.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Pushes three characters onto string" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-DT-push-month: func [ 11 | {private} 12 | s [c-string!] 13 | a [byte!] 14 | b [byte!] 15 | c [byte!] 16 | ][ 17 | s/1: a 18 | s/2: b 19 | s/3: c 20 | ] 21 | 22 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-init-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-init" 4 | --test-- "mi1" 5 | mi1-mp-int: declare LTM-int! 6 | response: LTM-init mi1-mp-int 7 | --assert response = LTM-OKAY 8 | --assert mi1-mp-int/used = 0 9 | --assert mi1-mp-int/alloc = LTM-PREC 10 | --assert mi1-mp-int/sign = LTM-ZPOS 11 | --assert 0 <> as integer! mi1-mp-int/mp-digit 12 | mi1-i: mi1-mp-int/alloc 13 | until [ 14 | --assert mi1-mp-int/mp-digit/value = null-byte 15 | mi1-mp-int/mp-digit: mi1-mp-int/mp-digit + 1 16 | mi1-i: mi1-i - 1 17 | mi1-i = 0 18 | ] 19 | ===end-group=== 20 | -------------------------------------------------------------------------------- /Core/PWAW-C-core.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Core support functions library" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | #include %PWAW-C-load-int.reds 10 | #include %PWAW-C-mold-int.reds 11 | #include %PWAW-C-str-copy.reds 12 | #include %PWAW-C-str-equal.reds 13 | #include %PWAW-C-str-init.reds 14 | #include %PWAW-C-str-int.reds 15 | #include %PWAW-C-substr.reds 16 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-push-two-digits.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Push number as two digits into string" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011-2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %../Core/PWAW-C-core.reds 11 | 12 | PWAW-DT-push-two-digits: func [ 13 | {private} 14 | i [integer!] 15 | s [c-string!] 16 | ][ 17 | if i < 10 [ 18 | s/1: #"0" 19 | s: s + 1 20 | ] 21 | PWAW-C-mold-int i s 22 | ] 23 | 24 | -------------------------------------------------------------------------------- /ShareAnalysis/share-analysis-test.red: -------------------------------------------------------------------------------- 1 | red [ 2 | Title: "Share Analysis Test" 3 | Author: "Peter W A Wood" 4 | File: %share-analysis-test.red 5 | Purpose: "Runs tests of share-analysis.red " 6 | Tabs: 4 7 | 8 | Rights: "Copyright (C) 2016 Peter W A Wood. All rights reserved." 9 | License: { 10 | Distributed under the Boost Software License, Version 1.0. 11 | See https://github.com/red/red/blob/master/BSL-License.txt 12 | } 13 | ] 14 | 15 | do %../../../../Red/red/quick-test/quick-test.red 16 | 17 | ***start-run*** "Share Analysis Test" 18 | 19 | do %share-analysis-core-test.red 20 | do %share-analysis-view-test.red 21 | 22 | ***end-run*** 23 | 24 | unview 25 | print "" -------------------------------------------------------------------------------- /LibTom/Tests/mp-init-size-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-init-size" 4 | --test-- "mis1" 5 | mis1-mp-int: declare LTM-int! 6 | response: LTM-init-size mis1-mp-int 1 7 | --assert response = LTM-OKAY 8 | --assert mis1-mp-int/used = 0 9 | --assert mis1-mp-int/alloc = (2 * LTM-PREC) 10 | --assert mis1-mp-int/sign = LTM-ZPOS 11 | --assert 0 <> as integer! mis1-mp-int/mp-digit 12 | mis1-i: mis1-mp-int/alloc 13 | mis1-bp: mis1-mp-int/mp-digit 14 | until [ 15 | --assert mis1-bp/value = null-byte 16 | mis1-bp: mis1-bp + 1 17 | mis1-i: mis1-i - 1 18 | mis1-i = 0 19 | ] 20 | response: LTM-clear mis1-mp-int 21 | --assert response = LTM-OKAY 22 | 23 | ===end-group=== -------------------------------------------------------------------------------- /DateTime/PWAW-DT-leapyear.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Worksout if a year is a leap year" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | 11 | PWAW-DT-leapyear?: func [ 12 | year [integer!] 13 | return: [logic!] 14 | /local 15 | leapyear [logic!] 16 | ][ 17 | leapyear: false 18 | if 0 = (year % 4) [ 19 | leapyear: true 20 | if 0 = (year % 100) [ 21 | leapyear: false 22 | if 0 = (year % 1000) [leapyear: true] 23 | ] 24 | ] 25 | leapyear 26 | ] 27 | -------------------------------------------------------------------------------- /LibTom/LTM-zero.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Sets a mp-int to zero" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-zero: func [ 12 | "Sets a mp-int to zero" 13 | mp-int [LTM-int!] "The integer to be zeroed" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | /local 16 | i [integer!] 17 | ][ 18 | 19 | mp-int/sign: LTM-ZPOS 20 | mp-int/used: 0 21 | 22 | i: 1 23 | until [ 24 | mp-int/mp-digit/i: LTM-ZERO-DIGIT 25 | i: i + 1 26 | i > mp-int/alloc 27 | ] 28 | 29 | LTM-OKAY 30 | 31 | ] -------------------------------------------------------------------------------- /DateTime/PWAW-DT-duration-def.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Duration Structure Definition" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-DT-duration!: alias struct! [ 11 | days [integer!] 12 | hours [integer!] 13 | minutes [integer!] 14 | seconds [integer!] 15 | microseconds [integer!] 16 | ] 17 | 18 | #define PWAW-DT-ZERO-DURATION(dur) [ 19 | dur/days: 0 20 | dur/hours: 0 21 | dur/minutes: 0 22 | dur/seconds: 0 23 | dur/microseconds: 0 24 | ] 25 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-store-int.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Check and load an integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %../Core/PWAW-C-core.reds 11 | 12 | PWAW-DT-store-int: func [ 13 | {private} 14 | s [c-string!] 15 | pi [pointer! [integer!]] 16 | return: [integer!] 17 | ][ 18 | if any [ 19 | not PWAW-C-str-int? s 20 | 0 <> PWAW-C-load-int s pi 21 | ][ 22 | return 1 23 | ] 24 | 25 | 0 26 | ] 27 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-set-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-set" 4 | 5 | --test-- "mpset1" 6 | mpset1-mp-int: declare LTM-int! 7 | response: LTM-init mpset1-mp-int 8 | --assert response = LTM-OKAY 9 | response: LTM-set mpset1-mp-int as LTM-digit! 1 10 | --assert response = LTM-OKAY 11 | --assert mpset1-mp-int/used = 1 12 | --assert mpset1-mp-int/mp-digit/value = as LTM-digit! 1 13 | 14 | --test-- "mpset2" 15 | mpset2-mp-int: declare LTM-int! 16 | response: LTM-init mpset2-mp-int 17 | --assert response = LTM-OKAY 18 | response: LTM-set mpset2-mp-int as LTM-digit! 127 19 | --assert response = LTM-OKAY 20 | --assert mpset2-mp-int/used = 1 21 | --assert mpset2-mp-int/mp-digit/value = as LTM-digit! 127 22 | 23 | ===end-group=== 24 | -------------------------------------------------------------------------------- /I64/PWAW-I64-negate.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Negates a 64-bit integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | 12 | PWAW-I64-negate: func [ 13 | a [PWAW-I64-int64!] 14 | b [PWAW-I64-int64!] 15 | return: [integer!] 16 | /local 17 | carry [integer!] 18 | ][ 19 | either 0 = a/least-sig [ 20 | carry: 1 21 | ][ 22 | carry: 0 23 | ] 24 | b/least-sig: (not a/least-sig) + 1 25 | b/most-sig: (not a/most-sig) + carry 26 | PWAW-I64-OKAY 27 | ] 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /I64/Tests/int64-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | 10 | ***start-run*** "Int64 Library Test" 11 | 12 | #include %abs-add-test.reds 13 | #include %abs-div-test.reds 14 | #include %abs-mul-test.reds 15 | #include %abs-sub-test.reds 16 | #include %add-test.reds 17 | #include %div-test.reds 18 | #include %mul-test.reds 19 | #include %greater-test.reds 20 | #include %negate-test.reds 21 | #include %shift-left-test.reds 22 | #include %shift-right-test.reds 23 | #include %sub-test.reds 24 | 25 | ***end-run*** 26 | -------------------------------------------------------------------------------- /Core/Tests/str-init-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - str-init test script" 3 | Author: "Peter W A Wood" 4 | File: %substr-test.reds 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "str-init" 13 | 14 | --test-- "si1" 15 | si1-str: as c-string! allocate 6 16 | --assert 0 = PWAW-C-str-init si1-str 5 #" " 17 | --assert #" " = si1-str/1 18 | --assert #" " = si1-str/2 19 | --assert #" " = si1-str/3 20 | --assert #" " = si1-str/4 21 | --assert #" " = si1-str/5 22 | --assert null-byte = si1-str/6 23 | free as byte-ptr! si1-str 24 | 25 | ~~~end-file~~~ 26 | 27 | -------------------------------------------------------------------------------- /LibTom/LTM-abs.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Provides the absolute value of a mp-int" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-abs: func [ 12 | "Provides the absolute value of a mp-int" 13 | a [LTM-int!] "The original integer" 14 | b [LTM-int!] "The absolute value" 15 | return: [integer!] "LTM-OKAY or an error code" 16 | /local 17 | response [integer!] 18 | ][ 19 | ;; copy a to b 20 | if a <> b [ 21 | response: LTM-copy a b 22 | if response <> LTM-OKAY [return response] 23 | ] 24 | 25 | ;; force sign of b to positive 26 | b/sign: LTM-ZPOS 27 | 28 | LTM-OKAY 29 | 30 | ] 31 | -------------------------------------------------------------------------------- /Core/PWAW-C-str-init.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Initialise a string" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-C-str-init: func [ 11 | { initialise a string} 12 | string [c-string!] "string to be initialised" 13 | num [integer!] "number of chars to init" 14 | char [byte!] "the initialisation value" 15 | return: [integer!] {returns 16 | 0 successful 17 | } 18 | /local 19 | i [integer!] 20 | ][ 21 | i: 1 22 | until [ 23 | string/i: char 24 | i: i + 1 25 | i > num 26 | ] 27 | string/i: null-byte 28 | 29 | 0 30 | ] 31 | 32 | -------------------------------------------------------------------------------- /I64/PWAW-I64-int64.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "64-bit integer arithmetic library" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | 12 | #include %PWAW-I64-abs-add.reds 13 | #include %PWAW-I64-abs-div.reds 14 | #include %PWAW-I64-abs-mul.reds 15 | #include %PWAW-I64-abs-sub.reds 16 | #include %PWAW-I64-add.reds 17 | #include %PWAW-I64-div.reds 18 | #include %PWAW-I64-greater.reds 19 | #include %PWAW-I64-mul.reds 20 | #include %PWAW-I64-negate.reds 21 | #include %PWAW-I64-shift-left.reds 22 | #include %PWAW-I64-shift-right.reds 23 | #include %PWAW-I64-sub.reds 24 | 25 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-clear-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-clear" 4 | --test-- "mc1" 5 | mc1-mp-int: declare LTM-int! 6 | response: LTM-init mc1-mp-int 7 | --assert response = LTM-OKAY 8 | mc1-mp-int/used: 1 9 | mc1-mp-int/sign: LTM-NEG 10 | response: LTM-clear mc1-mp-int 11 | --assert response = LTM-OKAY 12 | --assert mc1-mp-int/used = 0 13 | --assert mc1-mp-int/alloc = 0 14 | --assert mc1-mp-int/sign = LTM-ZPOS 15 | --assert mc1-mp-int/mp-digit = as byte-ptr! 0 16 | 17 | --test-- "mc2" 18 | mc2-mp-int: declare LTM-int! 19 | response: LTM-init mc2-mp-int 20 | --assert response = LTM-OKAY 21 | response: LTM-clear mc2-mp-int 22 | --assert response = LTM-OKAY 23 | mc2-mp-int/used: 1 24 | response: LTM-clear mc2-mp-int 25 | --assert response = LTM-INVALID 26 | --assert mc2-mp-int/used = 1 27 | ===end-group=== 28 | -------------------------------------------------------------------------------- /Core/Tests/str-equal-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - str-equal? test script" 3 | Author: "Peter W A Wood" 4 | File: %str-equal?-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "str-equal?" 13 | 14 | --test-- "cs-1" 15 | --assert false = PWAW-C-str-equal? "aa" "a" 16 | 17 | --test-- "cs-2" 18 | --assert false = PWAW-C-str-equal? "ab" "aa" 19 | 20 | --test-- "cs-3" 21 | --assert false = PWAW-C-str-equal? "aa" "ab" 22 | 23 | --test-- "cs-4" 24 | --assert PWAW-C-str-equal? "a" "a" 25 | 26 | --test-- "cs-5" 27 | --assert PWAW-C-str-equal? "" "" 28 | 29 | 30 | ~~~end-file~~~ 31 | 32 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-year-as-days.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Returns a year as a number of days since 0/1/1" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-DT-year-as-days: func [ 11 | { 12 | Returns a year as a number of days since 0/1/1 13 | } 14 | y [integer!] {a year} 15 | days [pointer! [integer!]] {number of days} 16 | return: [integer!] {returns: 17 | 18 | 0 - Success 19 | 1 - Year must not be negative 20 | } 21 | ][ 22 | if y < 0 [ 23 | return 1 24 | ] 25 | 26 | days/value: (y * 365) + (y / 4) - (y / 100) + (y / 1000) 27 | 0 28 | ] 29 | 30 | -------------------------------------------------------------------------------- /LibTom/LTM-clamp.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Trims unused digits from an integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0.} 6 | ] 7 | 8 | #include %libtommaths.def 9 | 10 | LTM-clamp: func [ 11 | "Trims unused digits from an mp-int!" 12 | mp-int [LTM-int!] "The integer to be trimmed" 13 | return: [integer!] "LTM-OKAY or an error code" 14 | /local 15 | i [integer!] 16 | ][ 17 | 18 | ;; decrease used whilst the most significant digit is zero 19 | i: mp-int/used 20 | while [ 21 | all [ 22 | LTM-ZERO-DIGIT = mp-int/mp-digit/i 23 | mp-int/used <> 0 24 | ] 25 | ][ 26 | mp-int/used: mp-int/used - 1 27 | i: i - 1 28 | ] 29 | 30 | ;; make sure sign is positive if size is zero 31 | if mp-int/used = 0 [mp-int/sign: LTM-ZPOS] 32 | 33 | LTM-OKAY 34 | 35 | ] -------------------------------------------------------------------------------- /LibTom/LTM-copy-init.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Clones a multiple-precision integer" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | #include %LTM-copy.reds 12 | 13 | 14 | LTM-copy-init: func [ 15 | "Clones an mp-int, ie initialises an mp-int then copies the original" 16 | a [LTM-int!] "The cloan" 17 | b [LTM-int!] "The integer to be copied" 18 | return: [integer!] "LTM-OKAY or an error code" 19 | /local 20 | response [integer!] 21 | 22 | ][ 23 | 24 | ;; initialise the clone 25 | response: LTM-init a 26 | if response <> LTM-OKAY [return response] 27 | 28 | ;; copy the orignal into the clone 29 | LTM-copy b a 30 | 31 | ] -------------------------------------------------------------------------------- /Core/PWAW-C-str-copy.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Copies a string" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.1 5 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-C-str-copy: func [ 11 | ;; copies a string 12 | in [c-string!] 13 | out [c-string!] 14 | return: [integer!] 15 | ;; returns: 16 | ;; 0 - successful copy 17 | ;; 1 - supplied string too short 18 | ][ 19 | if in/1 = null-byte [ 20 | out/1: null-byte 21 | return 0 22 | ] 23 | until [ 24 | if out/1 = null-byte [return 1] 25 | out/1: in/1 26 | in: in + 1 27 | out: out + 1 28 | in/1 = null-byte 29 | ] 30 | out/1: null-byte 31 | 0 32 | ] 33 | -------------------------------------------------------------------------------- /LibTom/Tests/LTM-clear-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Lib Tom Maths clear tests" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/Red/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../../../../Languages/Red/quick-test/quick-test.reds 9 | #include %../libtommaths.def 10 | #include %../LTM-init.reds 11 | #include %../LTM-clear.reds 12 | 13 | print-digits: func [ 14 | mp-int [LTM-int!] 15 | /local 16 | bp [LTM-digit-ptr!] 17 | i [integer!] 18 | ][ 19 | print ["The digits (least significant first) are:" lf] 20 | bp: mp-int/mp-digit 21 | i: 0 22 | while [i < mp-int/used][ 23 | print [as integer! bp/value lf] 24 | i: i + 1 25 | bp: bp + 1 26 | ] 27 | ] 28 | 29 | ~~~start-file~~~ "LTM clear" 30 | #include %mp-clear-group.reds 31 | ~~~end-file~~~ 32 | 33 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-date-def.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Date Time Structure Definition" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-DT-date!: alias struct! [ 11 | year [integer!] 12 | month [integer!] 13 | day [integer!] 14 | hour [integer!] 15 | minutes [integer!] 16 | seconds [integer!] 17 | microseconds [integer!] 18 | tz-hours [integer!] 19 | tz-minutes [integer!] 20 | ] 21 | 22 | #define PWAW-DT-ZERO-DATE(d) [ 23 | d/year: 0 24 | d/month: 0 25 | d/hour: 0 26 | d/minutes: 0 27 | d/seconds: 0 28 | d/microseconds: 0 29 | d/tz-hours: 0 30 | d/tz-minutes: 0 31 | ] 32 | -------------------------------------------------------------------------------- /LibTom/LTM-cmp.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Compares two mp-ints" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-cmp: func [ 12 | "Compares two mp-ints " 13 | a [LTM-int!] "The first integer" 14 | b [LTM-int!] "The second integer" 15 | return: [integer!] "LTM-GT, LTM-EQ or LTM-LT" 16 | 17 | ][ 18 | 19 | ;; compare on basis of sign 20 | if a/sign <> b/sign [ 21 | either a/sign = LTM-NEG [ 22 | return LTM-LT 23 | ][ 24 | return LTM-GT 25 | ] 26 | ] 27 | 28 | ;; compare absolute values 29 | either a/sign = LTM-NEG [ 30 | LTM-cmp-mag b a ;; if negative reverse comparison 31 | ][ 32 | LTM-cmp-mag a b 33 | ] 34 | 35 | ] 36 | -------------------------------------------------------------------------------- /DateTime/Tests/leapyear-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System DateTime library - leapyear? test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "leap-year?" 12 | 13 | --test-- "ly-1" 14 | --assert not PWAW-DT-leapyear? 1 15 | 16 | --test-- "ly-2" 17 | --assert PWAW-DT-leapyear? 4 18 | 19 | --test-- "ly-3" 20 | --assert not PWAW-DT-leapyear? 5 21 | 22 | --test-- "ly-4" 23 | --assert PWAW-DT-leapyear? 1996 24 | 25 | --test-- "ly-5" 26 | --assert not PWAW-DT-leapyear? 1900 27 | 28 | --test-- "ly-6" 29 | --assert PWAW-DT-leapyear? 2000 30 | 31 | --test-- "ly-7" 32 | --assert PWAW-DT-leapyear? 2004 33 | 34 | ~~~end-file~~~ 35 | 36 | -------------------------------------------------------------------------------- /LibTom/Tests/LTM-copy-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Lib Tom Maths mod-2d tests" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../../../../Languages/Red/quick-test/quick-test.reds 9 | #include %../libtommaths.def 10 | #include %../LTM-init.reds 11 | #include %../LTM-set-int.reds 12 | #include %../LTM-copy.reds 13 | 14 | print-digits: func [ 15 | mp-int [LTM-int!] 16 | /local 17 | bp [LTM-digit-ptr!] 18 | i [integer!] 19 | ][ 20 | print ["The digits (least significant first) are:" lf] 21 | bp: mp-int/mp-digit 22 | i: 0 23 | while [i < mp-int/used][ 24 | print [as integer! bp/value lf] 25 | i: i + 1 26 | bp: bp + 1 27 | ] 28 | ] 29 | 30 | ~~~start-file~~~ "LTM div-2d" 31 | #include %mp-copy-group.reds 32 | ~~~end-file~~~ 33 | 34 | -------------------------------------------------------------------------------- /Core/Tests/str-copy-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - str-copy test script" 3 | Author: "Peter W A Wood" 4 | File: %str-copy-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "str-copy" 13 | 14 | --test-- "sc-1" 15 | s: "" 16 | --assert 0 = PWAW-C-str-copy "" s 17 | --assert PWAW-C-str-equal? "" s 18 | 19 | --test-- "sc-2" 20 | s: "" 21 | --assert 1 = PWAW-C-str-copy " " s 22 | 23 | --test-- "sc-3" 24 | s: "abcdefgh" 25 | --assert 0 = PWAW-C-str-copy " " s 26 | --assert PWAW-C-str-equal? " " s 27 | 28 | --test-- "sc-4" 29 | s: "abcde" 30 | --assert 0 = PWAW-C-str-copy "12345" s 31 | --assert PWAW-C-str-equal? "12345" s 32 | 33 | ~~~end-file~~~ 34 | 35 | -------------------------------------------------------------------------------- /LibTom/Tests/LTM-div-2d-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Lib Tom Maths div-2d tests" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../../../../Languages/Red/quick-test/quick-test.reds 9 | #include %../libtommaths.def 10 | #include %../LTM-init.reds 11 | #include %../LTM-set-int.reds 12 | #include %../LTM-div-2d.reds 13 | 14 | print-digits: func [ 15 | mp-int [LTM-int!] 16 | /local 17 | bp [LTM-digit-ptr!] 18 | i [integer!] 19 | ][ 20 | print ["The digits (least significant first) are:" lf] 21 | bp: mp-int/mp-digit 22 | i: 0 23 | while [i < mp-int/used][ 24 | print [as integer! bp/value lf] 25 | i: i + 1 26 | bp: bp + 1 27 | ] 28 | ] 29 | 30 | ~~~start-file~~~ "LTM div-2d" 31 | #include %mp-div-2d-group.reds 32 | ~~~end-file~~~ 33 | 34 | -------------------------------------------------------------------------------- /LibTom/Tests/LTM-mod-2d-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Lib Tom Maths mod-2d tests" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../../../../Languages/Red/quick-test/quick-test.reds 9 | #include %../libtommaths.def 10 | #include %../LTM-init.reds 11 | #include %../LTM-set-int.reds 12 | #include %../LTM-mod-2d.reds 13 | 14 | print-digits: func [ 15 | mp-int [LTM-int!] 16 | /local 17 | bp [LTM-digit-ptr!] 18 | i [integer!] 19 | ][ 20 | print ["The digits (least significant first) are:" lf] 21 | bp: mp-int/mp-digit 22 | i: 0 23 | while [i < mp-int/used][ 24 | print [as integer! bp/value lf] 25 | i: i + 1 26 | bp: bp + 1 27 | ] 28 | ] 29 | 30 | ~~~start-file~~~ "LTM div-2d" 31 | #include %mp-mod-2d-group.reds 32 | ~~~end-file~~~ 33 | 34 | -------------------------------------------------------------------------------- /Core/PWAW-C-str-equal.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Compares two strings, byte by byte" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.1 5 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-C-str-equal?: func [ 11 | ;; compares two strings byte by byte 12 | ;; returns logic! : 13 | ;; true - strings match 14 | ;; false - strings do not match 15 | 16 | s1 [c-string!] 17 | s2 [c-string!] 18 | return: [logic!] 19 | /local 20 | i [integer!] 21 | size-s1 [integer!] 22 | ][ 23 | i: 1 24 | size-s1: size? s1 25 | if (size-s1) <> (size? s2) [return false] 26 | if 1 = size-s1 [return true] 27 | until [ 28 | if s1/i <> s2/i [return false] 29 | i: i + 1 30 | s1/i = null-byte 31 | ] 32 | true 33 | ] 34 | 35 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-s-mul-digs-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "s-mul-digs" 4 | 5 | --test-- "smpmuld1" 6 | smuld1-mp-int1: declare LTM-int! 7 | response: LTM-init smuld1-mp-int1 8 | --assert response = LTM-OKAY 9 | response: LTM-set-int mpsetint1-mp-int 12698633 10 | --assert response = LTM-OKAY 11 | smuld1-mp-int2: declare LTM-int! 12 | response: LTM-init smuld1-mp-int2 13 | --assert response = LTM-OKAY 14 | smuld1-mp-int2/mp-digit/1: as LTM-digit! 3 15 | smuld1-mp-int3: declare LTM-int! 16 | response: LTM-init smuld1-mp-int3 17 | --assert response = LTM-OKAY 18 | response: LTM-s-mul-digs smuld1-mp-int1 smuld1-mp-int2 smuld1-mp-int3 5 19 | --assert response = LTM-OKAY 20 | --assert smuld1-mp-int3/mp-digit/1 = as LTM-digit! 27 21 | --assert smuld1-mp-int3/mp-digit/2 = as LTM-digit! 24 22 | --assert smuld1-mp-int3/mp-digit/3 = as LTM-digit! 21 23 | --assert smuld1-mp-int3/mp-digit/4 = as LTM-digit! 18 24 | 25 | ===end-group=== -------------------------------------------------------------------------------- /DateTime/Tests/date-time-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - test script" 3 | Author: "Peter W A Wood" 4 | File: %core-test.reds 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../../Core/PWAW-C-core.reds 11 | 12 | ***start-run*** "Date Time Tests" 13 | #include %date-difference-test.reds 14 | #include %date-to-days-test.reds 15 | #include %days-in-year-todate-test.reds 16 | #include %days-to-date-test.reds 17 | #include %duration-difference-test.reds 18 | #include %equal-test.reds 19 | #include %later-test.reds 20 | #include %leapyear-test.reds 21 | #include %load-date-test.reds 22 | #include %mold-date-test.reds 23 | #include %now-test.reds 24 | #include %store-int-test.reds 25 | #include %UTC-test.reds 26 | #include %year-as-days-test.reds 27 | ***end-run*** 28 | 29 | 30 | -------------------------------------------------------------------------------- /LibTom/LTM-negate.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Negates an mp-int" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-negate: func [ "Negates an mp-int" 12 | a [LTM-int!] "The original integer" 13 | b [LTM-int!] "The negated integer" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | /local 16 | response [integer!] 17 | ][ 18 | 19 | ;; copy a to b 20 | if a <> b [ 21 | response: LTM-copy a b 22 | if response <> LTM-OKAY [return response] 23 | ] 24 | 25 | ;; force sign of zero values to positive, otherwise swap the sign 26 | either LTM-zero?(b) [ 27 | b/sign: LTM-ZPOS 28 | ][ 29 | either a/sign = LTM-ZPOS [b/sign: LTM-NEG] [b/sign: LTM-ZPOS] 30 | ] 31 | 32 | LTM-OKAY 33 | ] -------------------------------------------------------------------------------- /I64/PWAW-I64-greater.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Checks one 64-bit integer is greater than another" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | 12 | PWAW-I64-greater?: func [ 13 | a [PWAW-I64-int64!] 14 | b [PWAW-I64-int64!] 15 | return: [logic!] 16 | ][ 17 | case [ 18 | 19 | all [ 20 | PWAW-I64-negative?(a) 21 | PWAW-I64-positive?(b) 22 | ][ 23 | false 24 | ] 25 | 26 | all [ 27 | PWAW-I64-positive?(a) 28 | PWAW-I64-negative?(b) 29 | ][ 30 | true 31 | ] 32 | 33 | a/most-sig > b/most-sig [ 34 | true 35 | ] 36 | 37 | b/most-sig > a/most-sig [ 38 | false 39 | ] 40 | 41 | (as int-ptr! a/least-sig) > (as int-ptr! b/least-sig) [ 42 | true 43 | ] 44 | 45 | true [false] 46 | ] 47 | ] 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /LibTom/LTM-clear.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Clears a mp-int freeing the memory used for digits" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | License: {See https://github.com/red/red/blob/master/system/runtime/BSL-License.txt} 6 | ] 7 | 8 | #include %libtommaths.def 9 | 10 | LTM-clear: func [ 11 | "Clears a mp-int freeing the memory used for digits" 12 | mp-int [LTM-int!] "The integer to be cleared" 13 | return: [integer!] "LTM-OKAY or an error code" 14 | ][ 15 | 16 | ;; check if the integer has already been cleared 17 | if mp-int/mp-digit = as LTM-digit-ptr! 0 [return LTM-INVALID] 18 | 19 | ;; zero the digits before releasing the memory in case the user has 20 | ;; mistakenly stored the address of the digits 21 | if mp-int/used > 0 [ 22 | LTM-zero-set(mp-int/mp-digit 1 mp-int/used) 23 | ] 24 | 25 | ;; free the memory 26 | free mp-int/mp-digit 27 | 28 | ;; reset the structure members 29 | mp-int/mp-digit: as LTM-digit-ptr! 0 30 | mp-int/alloc: 0 31 | mp-int/used: 0 32 | mp-int/sign: LTM-ZPOS 33 | 34 | LTM-OKAY 35 | 36 | ] -------------------------------------------------------------------------------- /LibTom/LTM-init.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Initalises a new mp-int (multiple-precision integer)" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-init: func [ 12 | "Initalises a new mp-int (multiple-precision integer)" 13 | mp-int [LTM-int!] "The integer to be intialised" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | ][ 16 | 17 | ;; allocate the memory 18 | mp-int/mp-digit: allocate LTM-PREC 19 | 20 | ;; return memory error if memory not allocated 21 | if mp-int/mp-digit = as LTM-digit-ptr! 0 [return LTM-MEM] 22 | 23 | ;; set the digits to zero 24 | LTM-zero-set(mp-int/mp-digit 1 LTM-PREC) 25 | 26 | ;; set the used to zero, allocated digits to the default precision 27 | ;; and sign to positive 28 | mp-int/used: 0 29 | mp-int/alloc: LTM-PREC 30 | mp-int/sign: LTM-ZPOS 31 | LTM-OKAY 32 | 33 | ] -------------------------------------------------------------------------------- /DateTime/Tests/now-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - now test script" 3 | Author: "Peter W A Wood" 4 | File: %now-test.reds 5 | Rights: "Copyright (C) 2011 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-DT-date-time.reds 11 | 12 | ~~~start-file~~~ "now" 13 | 14 | n-now: declare PWAW-DT-date! 15 | 16 | --test-- "tv-1" 17 | --assert 0 = PWAW-DT-now n-now 18 | --assert n-now/year > 2012 19 | --assert n-now/month > 0 20 | --assert n-now/month < 13 21 | --assert n-now/day > 0 22 | --assert n-now/day < 32 23 | --assert n-now/minutes >= 0 24 | --assert n-now/minutes < 60 25 | --assert n-now/seconds >= 0 26 | --assert n-now/seconds <= 60 27 | --assert n-now/microseconds >= 0 28 | --assert n-now/microseconds < 1000000 29 | --assert n-now/tz-hours > -15 30 | --assert n-now/tz-hours < 15 31 | --assert n-now/tz-minutes >= 0 32 | --assert n-now/tz-minutes < 60 33 | 34 | ~~~end-file~~~ 35 | 36 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-set-int-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-set-int" 4 | 5 | --test-- "mpsetint1" 6 | mpsetint1-mp-int: declare LTM-int! 7 | response: LTM-init mpsetint1-mp-int 8 | --assert response = LTM-OKAY 9 | response: LTM-set-int mpsetint1-mp-int 12698633 10 | --assert response = LTM-OKAY 11 | --assert mpsetint1-mp-int/used = 4 12 | --assert mpsetint1-mp-int/mp-digit/1 = as LTM-digit! 9 13 | --assert mpsetint1-mp-int/mp-digit/2 = as LTM-digit! 8 14 | --assert mpsetint1-mp-int/mp-digit/3 = as LTM-digit! 7 15 | --assert mpsetint1-mp-int/mp-digit/4 = as LTM-digit! 6 16 | 17 | --test-- "mpsetint2" 18 | mpsetint2-mp-int: declare LTM-int! 19 | response: LTM-init mpsetint2-mp-int 20 | --assert response = LTM-OKAY 21 | response: LTM-set-int mpsetint2-mp-int 2097023 22 | --assert response = LTM-OKAY 23 | --assert mpsetint2-mp-int/used = 3 24 | --assert mpsetint2-mp-int/mp-digit/1 = as LTM-digit! 127 25 | --assert mpsetint2-mp-int/mp-digit/2 = as LTM-digit! 126 26 | --assert mpsetint2-mp-int/mp-digit/3 = as LTM-digit! 127 27 | 28 | ===end-group=== 29 | -------------------------------------------------------------------------------- /I64/PWAW-I64-abs-add.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Sum of the absolute values of two 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-greater.reds 12 | 13 | PWAW-I64-abs-add: func [ 14 | a [PWAW-I64-int64!] 15 | b [PWAW-I64-int64!] 16 | c [PWAW-I64-int64!] 17 | return: [integer!] 18 | /local 19 | carry [integer!] 20 | ][ 21 | 22 | c/least-sig: a/least-sig + b/least-sig 23 | either any [ 24 | (as int-ptr! a/least-sig) > (as int-ptr! c/least-sig) 25 | (as int-ptr! b/least-sig) > (as int-ptr! c/least-sig) 26 | ][ 27 | carry: 1 28 | ][ 29 | carry: 0 30 | ] 31 | c/most-sig: a/most-sig + b/most-sig + carry 32 | either any [ 33 | PWAW-I64-greater? a c 34 | PWAW-I64-greater? b c 35 | ][ 36 | PWAW-I64-OVERFLOW 37 | ][ 38 | PWAW-I64-OKAY 39 | ] 40 | ] 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-grow-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-grow" 4 | 5 | --test-- "mg1" 6 | mg1-mp-int: declare LTM-int! 7 | response: LTM-init mg1-mp-int 8 | --assert response = LTM-OKAY 9 | mg1-i: mg1-mp-int/mp-digit 10 | mg1-i/value: #"^(01)" 11 | mg1-i: mg1-i + 1 12 | mg1-i/value: #"^(FF)" 13 | mg1-bp: allocate 8 ;; allocate memory to try to avoid 14 | ;; same memory being allocated. 15 | response: LTM-grow mg1-mp-int LTM-PREC + 1 16 | --assert response = LTM-OKAY 17 | --assert mg1-mp-int/alloc = (3 * LTM-PREC) 18 | mg1-j: mg1-mp-int/mp-digit 19 | --assert mg1-j/value = #"^(01)" 20 | mg1-j: mg1-j + 1 21 | --assert mg1-j/value = #"^(FF)" 22 | free mg1-bp 23 | response: LTM-clear mg1-mp-int 24 | --assert response = LTM-OKAY 25 | 26 | --test-- "mg2" 27 | mg2-mp-int: declare LTM-int! 28 | response: LTM-init mg2-mp-int 29 | --assert response = LTM-OKAY 30 | response: LTM-grow mg2-mp-int LTM-PREC - 1 31 | --assert response = LTM-OKAY 32 | --assert mg2-mp-int/alloc = LTM-PREC 33 | response: LTM-clear mg2-mp-int 34 | --assert response = LTM-OKAY 35 | 36 | ===end-group=== 37 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-equal.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Compares two date time structures" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-DT-UTC.reds 11 | 12 | PWAW-DT-equal?: func [ 13 | d1 [PWAW-DT-date!] 14 | d2 [PWAW-DT-date!] 15 | return: [logic!] 16 | /local 17 | utc-d1 [PWAW-DT-date!] 18 | utc-d2 [PWAW-DT-date!] 19 | 20 | ][ 21 | utc-d1: declare PWAW-DT-date! 22 | utc-d2: declare PWAW-DT-date! 23 | if 0 <> PWAW-DT-UTC d1 utc-d1 [return false] 24 | if 0 <> PWAW-DT-UTC d2 utc-d2 [return false] 25 | 26 | either all [ 27 | utc-d1/year = utc-d2/year 28 | utc-d1/month = utc-d2/month 29 | utc-d1/day = utc-d2/day 30 | utc-d1/hour = utc-d2/hour 31 | utc-d1/minutes = utc-d2/minutes 32 | utc-d1/seconds = utc-d2/seconds 33 | utc-d1/microseconds = utc-d2/microseconds 34 | 35 | ][ 36 | true 37 | ][ 38 | false 39 | ] 40 | 41 | ] 42 | -------------------------------------------------------------------------------- /LibTom/LTM-init-size.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Initalises a new mp-int (multiple-precision integer) to a given size" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | License: {https://github.com/red/red/blob/master/BSL-License.txt} 6 | ] 7 | 8 | #include %libtommaths.def 9 | 10 | LTM-init-size: func [ 11 | "Initalises a new mp-int (multiple-precision integer) to a given size" 12 | mp-int [LTM-int!] "The integer to be intialised" 13 | size [integer!] "Minimum number of digits" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | ][ 16 | 17 | ;; ensure that there are always at least LTM-PREC digits empty 18 | LTM-pad-size(size) 19 | 20 | ;; allocate the memory 21 | mp-int/mp-digit: allocate size 22 | 23 | ;; return memory error if memory not allocated 24 | if mp-int/mp-digit = as LTM-digit-ptr! 0 [return LTM-MEM] 25 | 26 | ;; set the digits to zero 27 | LTM-zero-set(mp-int/mp-digit 1 LTM-PREC) 28 | 29 | ;; set the used to zero, allocated digits to the default precision 30 | ;; and sign to positive 31 | mp-int/used: 0 32 | mp-int/alloc: 2 * LTM-PREC 33 | mp-int/sign: LTM-ZPOS 34 | LTM-OKAY 35 | ] 36 | -------------------------------------------------------------------------------- /run-test.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/ruby 2 | 3 | =begin 4 | Purpose Builds and runs Red/System Library tests 5 | Author Peter W A Wood 6 | Version 0.0.4 7 | Rights Copyright © 2011-2013 Peter W A Wood. All rights reserved. 8 | License BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt 9 | Notes Requires the file path-to-red.txt to be in the same directory. 10 | =end 11 | 12 | # extract the program name from the source file and 13 | # work out where everything is 14 | source_file = ARGV[0] 15 | pgm_name = File.basename(source_file, '.*') 16 | pgm_path = File.expand_path(source_file) 17 | pgm_dir = File.dirname(pgm_path) 18 | runnable_dir = File.join(File.expand_path(File.dirname(__FILE__)),'Runnable') 19 | pgm = File.join(runnable_dir, pgm_name) 20 | reds_libs_dir = File.dirname(__FILE__) 21 | compiler_dir = IO.read(File.join(reds_libs_dir, 'path-to-red.txt')) 22 | 23 | # make runnable directory if needed 24 | if !File.directory? runnable_dir then 25 | Dir.mkdir runnable_dir 26 | end 27 | 28 | # compile, relocate executable and run 29 | if system('rebol -qs '+ compiler_dir + 'red.r -o ' + pgm + ' ' + pgm_path) then 30 | system(pgm) 31 | end 32 | -------------------------------------------------------------------------------- /LibTom/LTM-set.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Sets a mp-int to a digit" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | File: %libtommaths.reds 6 | Descripton: "A reduced implementation of LibTomMath authored by Tom St Denis" 7 | License: {Distributed under the Boost Software License, Version 1.0. 8 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 9 | ] 10 | 11 | #include %libtommaths.def 12 | 13 | LTM-set: func [ 14 | "Sets a mp-int to a digit" 15 | mp-int [LTM-int!] "The integer to be set" 16 | mp-digit [LTM-digit!] "The digit" 17 | return: [integer!] "LTM-OKAY or an error code" 18 | /local 19 | response [integer!] 20 | ][ 21 | ;; check number can be stored in a single digit 22 | if mp-digit > LTM-MASK [return LTM-TOO-BIG] 23 | 24 | ;; set to zero 25 | response: LTM-zero mp-int 26 | if response <> LTM-OKAY [return response] 27 | 28 | ; set first digit 29 | mp-int/mp-digit/value: mp-digit and LTM-MASK 30 | either mp-int/mp-digit/value = LTM-ZERO-DIGIT [ 31 | mp-int/used: 0 32 | ][ 33 | mp-int/used: 1 34 | ] 35 | 36 | LTM-OKAY 37 | 38 | ] -------------------------------------------------------------------------------- /Core/PWAW-C-substr.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Return a sub-sting from a string" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-C-substr: func [ 11 | { returns a sub-string of a string} 12 | string [c-string!] "original string" 13 | index [integer!] {start of sub-string,one-based} 14 | length [integer!] {length of sub-string} 15 | substr [c-string!] {the substing} 16 | return: [integer!] {returns 17 | 0 successful 18 | 1 provided string too short 19 | 2 invalid substring start or length 20 | } 21 | /local 22 | i [integer!] 23 | j [integer!] 24 | ][ 25 | if length > length? substr [return 1] 26 | 27 | if any [ 28 | index < 1 29 | index > length? string 30 | (length? string) < (index + length - 1) 31 | ][ 32 | return 2 33 | ] 34 | 35 | i: index 36 | J: 1 37 | until [ 38 | substr/j: string/i 39 | i: i + 1 40 | j: j + 1 41 | j > length 42 | ] 43 | substr/j: null-byte 44 | 45 | 0 46 | ] 47 | 48 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-init-multi-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-init-multi" 4 | 5 | --test-- "mim1" 6 | mim1-mp-int1: declare LTM-int! 7 | mim1-mp-int2: declare LTM-int! 8 | response: LTM-init-multi [mim1-mp-int1 mim1-mp-int2] 9 | --assert response = LTM-OKAY 10 | --assert mim1-mp-int1/used = 0 11 | --assert mim1-mp-int2/used = 0 12 | --assert mim1-mp-int1/alloc = LTM-PREC 13 | --assert mim1-mp-int2/alloc = LTM-PREC 14 | --assert mim1-mp-int1/sign = LTM-ZPOS 15 | --assert mim1-mp-int2/sign = LTM-ZPOS 16 | --assert 0 <> as integer! mim1-mp-int1/mp-digit 17 | --assert 0 <> as integer! mim1-mp-int2/mp-digit 18 | mim1-i: mim1-mp-int1/alloc 19 | mim1-bp: mim1-mp-int1/mp-digit 20 | until [ 21 | --assert mim1-bp/value = null-byte 22 | mim1-bp: mim1-bp + 1 23 | mim1-i: mim1-i - 1 24 | mim1-i = 0 25 | ] 26 | response: LTM-clear mim1-mp-int1 27 | --assert response = LTM-OKAY 28 | mim1-i: mim1-mp-int2/alloc 29 | mim1-bp: mim1-mp-int2/mp-digit 30 | until [ 31 | --assert mim1-bp/value = null-byte 32 | mim1-bp: mim1-bp + 1 33 | mim1-i: mim1-i - 1 34 | mim1-i = 0 35 | ] 36 | response: LTM-clear mim1-mp-int2 37 | --assert response = LTM-OKAY 38 | 39 | ===end-group=== 40 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-date-time.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "A basic date-time library" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %../Core/PWAW-C-core.reds 11 | 12 | #include %PWAW-DT-date-def.reds 13 | #include %PWAW-DT-duration-def.reds 14 | 15 | #switch OS [ 16 | Windows [#include %PWAW-DT-date-time-win32.reds] 17 | #default [#include %PWAW-DT-date-time-libc.reds] 18 | ] 19 | 20 | #include %PWAW-DT-date-difference.reds 21 | #include %PWAW-DT-date-to-days.reds 22 | #include %PWAW-DT-days-in-year-todate.reds 23 | #include %PWAW-DT-days-to-date.reds 24 | #include %PWAW-DT-duration-difference.reds 25 | #include %PWAW-DT-equal.reds 26 | #include %PWAW-DT-later.reds 27 | #include %PWAW-DT-leapyear.reds 28 | #include %PWAW-DT-load-date.reds 29 | #include %PWAW-DT-mold-date.reds 30 | #include %PWAW-DT-push-month.reds 31 | #include %PWAW-DT-push-two-digits.reds 32 | #include %PWAW-DT-store-int.reds 33 | #include %PWAW-DT-UTC.reds 34 | #include %PWAW-DT-year-as-days.reds 35 | -------------------------------------------------------------------------------- /LibTom/LTM-cmp-mag.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Compares the magnitude of two mp-ints (unsigned)" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | #include %LTM-abs.reds 12 | #include %LTM-add.reds 13 | #include %LTM-clamp.reds 14 | #include %LTM-clear.reds 15 | #include %LTM-cmp.reds 16 | 17 | LTM-cmp-mag: func [ 18 | "Compares the magnitude of two mp-ints (unsigned)" 19 | a [LTM-int!] "The first integer" 20 | b [LTM-int!] "The second integer" 21 | return: [integer!] "LTM-GT, LTM-EQ or LTM-LT" 22 | /local 23 | i [integer!] 24 | 25 | ][ 26 | 27 | ;; compare on basis of non-zero digits 28 | if a/used > b/used [return LTM-GT] 29 | if a/used < b/used [return LTM-LT] 30 | if a/used = 0 [return LTM-EQ] ;; both are zero 31 | 32 | ;;compare from most significant digit 33 | i: a/used 34 | until [ 35 | if a/mp-digit/i > b/mp-digit/i [return LTM-GT] 36 | if a/mp-digit/i < b/mp-digit/i [return LTM-LT] 37 | 38 | i: i - 1 39 | i < 1 40 | ] 41 | 42 | LTM-EQ 43 | 44 | ] -------------------------------------------------------------------------------- /LibTom/libtommaths.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Multiple-precision integer library" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | File: %libtommaths.reds 6 | Descripton: "A reduced implementation of LibTomMath authored by Tom St Denis" 7 | License: {Distributed under the Boost Software License, Version 1.0. 8 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 9 | ] 10 | 11 | #include %libtommaths.def 12 | 13 | #include %LTM-abs.reds 14 | #include %LTM-add.reds 15 | #include %LTM-clamp.reds 16 | #include %LTM-clear.reds 17 | #include %LTM-cmp.reds 18 | #include %LTM-cmp-mag.reds 19 | #include %LTM-copy.reds 20 | #include %LTM-copy-init.reds 21 | #include %LTM-div-2.reds 22 | #include %LTM-div-2d.reds 23 | #include %LTM-grow.reds 24 | #include %LTM-init.reds 25 | #include %LTM-init-multi.reds 26 | #include %LTM-init-size.reds 27 | #include %LTM-lshd.reds 28 | #include %LTM-mod-2d.reds 29 | #include %LTM-mul-2.reds 30 | #include %LTM-mul-2d.reds 31 | #include %LTM-negate.reds 32 | #include %LTM-rshd.reds 33 | #include %LTM-set.reds 34 | #include %LTM-set-int.reds 35 | #include %LTM-sub.reds 36 | #include %LTM-s-add.reds 37 | #include %LTM-s-mul-digs.reds 38 | #include %LTM-s-sub.reds 39 | #include %LTM-zero.reds 40 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-copy-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-copy" 4 | 5 | --test-- "mcpy1" 6 | mcpy1-mp-int1: declare LTM-int! 7 | response: LTM-init mcpy1-mp-int1 8 | --assert response = LTM-OKAY 9 | mcpy1-mp-int1/used: 1 10 | mcpy1-mp-int1/mp-digit/value: #"^(11)" 11 | response: LTM-copy mcpy1-mp-int1 mcpy1-mp-int1 12 | --assert response = LTM-OKAY 13 | --assert mcpy1-mp-int1/used = 1 14 | --assert mcpy1-mp-int1/sign = LTM-ZPOS 15 | --assert mcpy1-mp-int1/alloc = LTM-PREC 16 | --assert mcpy1-mp-int1/mp-digit/value = #"^(11)" 17 | 18 | --test-- "mcpy2" 19 | mcpy2-mp-int1: declare LTM-int! 20 | response: LTM-init mcpy2-mp-int1 21 | --assert response = LTM-OKAY 22 | mcpy2-mp-int1/used: LTM-PREC + 1 23 | mcpy2-mp-int1/mp-digit/value: #"^(21)" 24 | response: LTM-grow mcpy2-mp-int1 LTM-PREC + 1 25 | --assert response = LTM-OKAY 26 | mcpy2-mp-int2: declare LTM-int! 27 | response: LTM-init mcpy2-mp-int2 28 | --assert response = LTM-OKAY 29 | response: LTM-copy mcpy2-mp-int1 mcpy2-mp-int2 30 | --assert response = LTM-OKAY 31 | --assert mcpy2-mp-int2/used = 33 ;; mp-copy doesn't clamp 32 | --assert mcpy2-mp-int2/sign = LTM-ZPOS 33 | --assert mcpy2-mp-int2/alloc = (3 * LTM-PREC) 34 | --assert mcpy2-mp-int2/mp-digit/value = #"^(21)" 35 | 36 | ===end-group=== 37 | -------------------------------------------------------------------------------- /LibTom/LTM-copy.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Copies an mp-int to another" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | #include %LTM-grow.reds 11 | 12 | LTM-copy: func [ 13 | "Copies an mp-int to another" 14 | a [LTM-int!] "The integer to be copied" 15 | b [LTM-int!] "The copy" 16 | return: [integer!] "LTM-OKAY or an error code" 17 | /local 18 | i [integer!] 19 | response [integer!] 20 | 21 | ][ 22 | 23 | ;; do nothing if a and b are the same 24 | if a = b [return LTM-OKAY] 25 | 26 | ;; expand the destination if needed 27 | if a/used > b/alloc [ 28 | response: LTM-grow b a/used 29 | if response <> LTM-OKAY [return response] 30 | ] 31 | 32 | ;; copy all the used digits from a to b 33 | if a/used > 0 [ 34 | i: 1 35 | until [ 36 | b/mp-digit/i: a/mp-digit/i 37 | i: i + 1 38 | i > a/used 39 | ] 40 | ] 41 | 42 | ;; clear any remaining digits previously set in b 43 | if b/used > a/used [ 44 | LTM-zero-set(b/mp-digit (a/used + 1) b/used) 45 | ] 46 | 47 | ;; copy used count and sign 48 | b/used: a/used 49 | b/sign: a/sign 50 | 51 | LTM-OKAY 52 | 53 | ] -------------------------------------------------------------------------------- /I64/PWAW-I64-abs-sub.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Subtract the values of two positive 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-greater.reds 12 | 13 | PWAW-I64-abs-sub: func [ 14 | "Subtract a positive integer from a larger one" 15 | a [PWAW-I64-int64!] 16 | b [PWAW-I64-int64!] 17 | c [PWAW-I64-int64!] 18 | return: [integer!] 19 | /local 20 | a-least [integer!] 21 | ][ 22 | 23 | if any [ 24 | a/most-sig < 0 25 | b/most-sig < 0 26 | PWAW-I64-greater? b a 27 | ][ 28 | return PWAW-I64-INVALID-ARG 29 | ] 30 | 31 | if PWAW-I64-equal?(a b) [ 32 | PWAW-I64-zero-int64(c) 33 | return PWAW-I64-OKAY 34 | ] 35 | 36 | a-least: a/least-sig 37 | c/most-sig: a/most-sig - b/most-sig 38 | c/least-sig: as integer! (as pointer! [integer!] a/least-sig) - 39 | (as pointer! [integer!] b/least-sig) 40 | if any [ 41 | (as pointer! [integer!] a-least) < 42 | (as pointer! [integer!] c/least-sig) 43 | ][ 44 | c/most-sig: c/most-sig - 1 45 | ] 46 | 47 | PWAW-I64-OKAY 48 | ] 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /I64/PWAW-I64-shift-right.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Right shift 64-bit integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | 12 | PWAW-I64-shift-right: func [ 13 | a [PWAW-I64-int64!] 14 | b [PWAW-I64-int64!] 15 | num-bits [integer!] 16 | return: [integer!] 17 | /local 18 | i [integer!] 19 | il [integer!] 20 | carry [integer!] 21 | ][ 22 | if num-bits > 63 [ 23 | return PWAW-I64-EXCESSIVE-SHIFT 24 | ] 25 | 26 | if num-bits = 0 [ 27 | PWAW-I64-copy(a b) 28 | return PWAW-I64-OKAY 29 | ] 30 | 31 | either num-bits > 31 [ 32 | b/least-sig: a/most-sig >>> (num-bits - 32) 33 | b/most-sig: 0 34 | ][ 35 | il: a/least-sig >>> num-bits 36 | i: 1 37 | carry: 0 38 | until [ 39 | carry: carry << 1 40 | carry: carry + 1 41 | i: i + 1 42 | i > num-bits 43 | ] 44 | carry: a/most-sig and carry 45 | if carry <> 0 [ 46 | carry: carry << (32 - num-bits) 47 | il: il or carry 48 | ] 49 | 50 | b/most-sig: a/most-sig >>> num-bits 51 | b/least-sig: il 52 | ] 53 | return PWAW-I64-OKAY 54 | ] 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /Core/Tests/substr-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - substr test script" 3 | Author: "Peter W A Wood" 4 | File: %substr-test.reds 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "substr" 13 | 14 | --test-- "ss1" 15 | ss1-str: "" 16 | --assert 1 = PWAW-C-substr "abcde" 1 3 ss1-str 17 | 18 | --test-- "ss2" 19 | ss1-str: " " 20 | --assert 2 = PWAW-C-substr "abcde" 5 3 ss1-str 21 | 22 | --test-- "ss3" 23 | ss1-str: " " 24 | --assert 2 = PWAW-C-substr "abcde" 0 3 ss1-str 25 | 26 | --test-- "ss4" 27 | ss1-str: " " 28 | --assert 2 = PWAW-C-substr "abcde" 6 3 ss1-str 29 | 30 | --test-- "ss5" 31 | ss-str: " " 32 | --assert 0 = PWAW-C-substr "abcde" 1 3 ss-str 33 | --assert PWAW-C-str-equal? "abc" ss-str 34 | --assert 3 = length? ss-str 35 | --assert 4 = size? ss-str 36 | 37 | --test-- "ss5" 38 | ss-str: " " 39 | --assert 0 = PWAW-C-substr "abcde" 5 1 ss-str 40 | --assert PWAW-C-str-equal? "e" ss-str 41 | --assert 1 = length? ss-str 42 | --assert 2 = size? ss-str 43 | 44 | ~~~end-file~~~ 45 | 46 | -------------------------------------------------------------------------------- /Core/PWAW-C-load-int.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Load integer function" 3 | Author: "Peter W A Wood" 4 | Version: 0.2 5 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-C-str-int.reds 11 | 12 | PWAW-C-load-int: func [ 13 | ;; loads an integer from a string into the supplied integer 14 | ;; it assumes that the string is a valid integer literal 15 | ;; this is initial versions only handles decimal integers 16 | ;; returns integer! : 17 | ;; 0 - successful 18 | ;; 1 - invalid integer supplied 19 | ;; 20 | ;; the function expects a c-string as the first argument 21 | ;; and a pointer to the integer to be loaded as its second. 22 | s [c-string!] 23 | i [pointer! [integer!]] 24 | return: [integer!] 25 | /local 26 | neg? [logic!] 27 | ][ 28 | if not PWAW-C-str-int? s [return 1] 29 | 30 | neg?: false 31 | if any [ 32 | s/1 = #"-" 33 | s/1 = #"+" 34 | ][ 35 | if s/1 = #"-" [neg?: true] 36 | s: s + 1 37 | ] 38 | 39 | i/value: 0 40 | until [ 41 | i/value: i/value * 10 42 | i/value: i/value + (s/1 - 48) 43 | s: s + 1 44 | s/1 = null-byte 45 | ] 46 | if neg? [i/value: i/value * -1] 47 | 0 48 | ] 49 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-copy-init-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-copy-init" 4 | 5 | --test-- "mcpyi1" 6 | mcpyi1-mp-int1: declare LTM-int! 7 | response: LTM-init mcpyi1-mp-int1 8 | --assert response = LTM-OKAY 9 | mcpyi1-mp-int1/used: 1 10 | mcpyi1-mp-int1/mp-digit/value: #"^(11)" 11 | mcpi1-mp-int2: declare LTM-int! 12 | mcpyi1-mp-int1/sign: LTM-NEG 13 | mcpyi1-mp-int2: declare LTM-int! 14 | response: LTM-copy-init mcpyi1-mp-int2 mcpyi1-mp-int1 15 | --assert response = LTM-OKAY 16 | --assert mcpyi1-mp-int2/used = 1 17 | --assert mcpyi1-mp-int2/sign = LTM-NEG 18 | --assert mcpyi1-mp-int2/alloc = LTM-PREC 19 | --assert mcpyi1-mp-int2/mp-digit/value = #"^(11)" 20 | 21 | --test-- "mcpyi2" 22 | mcpyi2-mp-int1: declare LTM-int! 23 | response: LTM-init mcpyi2-mp-int1 24 | --assert response = LTM-OKAY 25 | mcpyi2-mp-int1/used: LTM-PREC + 1 26 | mcpyi2-mp-int1/mp-digit/value: #"^(21)" 27 | response: LTM-grow mcpyi2-mp-int1 LTM-PREC + 1 28 | --assert response = LTM-OKAY 29 | mcpyi2-mp-int2: declare LTM-int! 30 | response: LTM-copy-init mcpyi2-mp-int2 mcpyi2-mp-int1 31 | --assert response = LTM-OKAY 32 | --assert mcpyi2-mp-int2/used = 33 ;; mp-copy doesn't clamp 33 | --assert mcpyi2-mp-int2/sign = LTM-ZPOS 34 | --assert mcpyi2-mp-int2/alloc = (3 * LTM-PREC) 35 | --assert mcpyi2-mp-int2/mp-digit/value = #"^(21)" 36 | 37 | ===end-group=== 38 | -------------------------------------------------------------------------------- /I64/PWAW-I64-shift-left.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Left shift 64-bit integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | 12 | PWAW-I64-shift-left: func [ 13 | a [PWAW-I64-int64!] 14 | b [PWAW-I64-int64!] 15 | num-bits [integer!] 16 | return: [integer!] 17 | /local 18 | i [integer!] 19 | carry [integer!] 20 | ][ 21 | if num-bits > 63 [ 22 | return PWAW-I64-EXCESSIVE-SHIFT 23 | ] 24 | 25 | if num-bits = 0 [ 26 | b/least-sig: a/least-sig 27 | b/most-sig: a/most-sig 28 | return PWAW-I64-OKAY 29 | ] 30 | 31 | either num-bits > 31 [ 32 | b/most-sig: a/least-sig << (num-bits - 32) 33 | b/least-sig: 0 34 | ][ 35 | i: 1 36 | carry: 0 37 | until [ 38 | carry: carry << 1 39 | carry: carry + 1 40 | i: i + 1 41 | i > num-bits 42 | ] 43 | carry: carry << (32 - num-bits) 44 | carry: a/least-sig and carry 45 | b/least-sig: a/least-sig << num-bits 46 | b/most-sig: a/most-sig << num-bits 47 | if carry <> 0 [ 48 | carry: carry >>> (32 - num-bits) 49 | b/most-sig: b/most-sig or carry 50 | ] 51 | ] 52 | return PWAW-I64-OKAY 53 | ] 54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /LibTom/LTM-grow.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Add space for more digits to a mp-int" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {https://github.com/red/red/blob/master/red-system/runtime/BSL-License.txt} 6 | ] 7 | 8 | #include %libtommaths.def 9 | 10 | LTM-grow: func [ 11 | "Add space for more digits to a mp-int" 12 | mp-int [LTM-int!] "The integer to be expanded" 13 | size [integer!] "The desired size of the mp-int" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | /local 16 | tmp [LTM-digit-ptr!] 17 | ][ 18 | 19 | ;; increase the size of mp-int if the requested size is greater than its 20 | ;; current size 21 | if mp-int/alloc < size [ 22 | 23 | ;; ensure that there are always at least LTM-PREC digits empty 24 | LTM-pad-size(size) 25 | 26 | ;; re-allocate the digit array 27 | ;; the required space is allocated to a temporary variable first 28 | ;; so that if there is a problem the original array is not lost 29 | tmp: allocate size 30 | if tmp = as LTM-digit-ptr! 0 [return LTM-MEM] 31 | 32 | ;; copy the existing data from mp-digit to tmp so that mp-digit can be 33 | ;; safely freed 34 | copy-memory tmp mp-int/mp-digit mp-int/alloc 35 | free mp-int/mp-digit 36 | mp-int/mp-digit: tmp 37 | 38 | ;; zero excess digits and set alloc 39 | LTM-zero-set(mp-int/mp-digit mp-int/alloc size) 40 | mp-int/alloc: size 41 | 42 | ] 43 | LTM-OKAY 44 | ] 45 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-days-in-year-todate.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Calculates number of days in the year excluding supplied date" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %../Core/PWAW-C-core.reds 11 | 12 | #include %PWAW-DT-date-def.reds 13 | 14 | PWAW-DT-days-in-year-todate: func [ 15 | {Calculates the number of days in the year before this date} 16 | d [PWAW-DT-date!] {the date} 17 | days [pointer! [integer!]] {the number of days calculated} 18 | return: [integer!] 19 | { 20 | 0 - successful 21 | } 22 | /local 23 | acc [integer!] 24 | ][ 25 | acc: 0 26 | switch d/month [ 27 | 1 [] 28 | 2 [acc: acc + 31] 29 | 3 [acc: acc + 59] 30 | 4 [acc: acc + 90] 31 | 5 [acc: acc + 120] 32 | 6 [acc: acc + 151] 33 | 7 [acc: acc + 181] 34 | 8 [acc: acc + 212] 35 | 9 [acc: acc + 243] 36 | 10 [acc: acc + 273] 37 | 11 [acc: acc + 304] 38 | 12 [acc: acc + 334] 39 | ] 40 | 41 | if d/month > 2 [ 42 | if 0 = (d/year % 4) [acc: acc + 1] 43 | if 0 = (d/year % 100) [acc: acc - 1] 44 | if 0 = (d/year % 400) [acc: acc + 1] 45 | ] 46 | 47 | acc: acc + d/day - 1 48 | 49 | days/value: acc 50 | 0 51 | ] 52 | -------------------------------------------------------------------------------- /LibTom/LTM-rshd.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Shift right a number of digits" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-rshd: func [ 12 | "Shift right a number of digits" 13 | mp-int [LTM-int!] "The integer to be right shifted" 14 | shift [integer!] "Number of digits to be shifted" 15 | return: [integer!] "LTM-OKAY or an error code" 16 | /local 17 | new-slot [integer!] ;; used to shift digits 18 | old-slot [integer!] ;; used to shift digits 19 | old-used [integer!] ;; store original used value 20 | ][ 21 | ;; if shift is 0 or less, there is nothing to do 22 | if shift < 1 [return LTM-OKAY] 23 | 24 | 25 | ;; copy the digits to their new position, starting with least significant 26 | ;; and set the used to reflect the shift 27 | old-used: mp-int/used 28 | old-slot: shift + 1 29 | mp-int/used: mp-int/used - shift 30 | new-slot: 1 31 | until [ 32 | mp-int/mp-digit/new-slot: mp-int/mp-digit/old-slot 33 | new-slot: new-slot + 1 34 | old-slot: old-slot + 1 35 | new-slot > mp-int/used 36 | ] 37 | 38 | ;; zero the upper digits 39 | LTM-zero-set(mp-int/mp-digit (mp-int/used + 1) old-used) 40 | 41 | LTM-OKAY 42 | ] -------------------------------------------------------------------------------- /LibTom/Tests/mp-abs-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-abs" 4 | 5 | --test-- "ma1" 6 | ma1-mp-int1: declare LTM-int! 7 | response: LTM-init ma1-mp-int1 8 | --assert response = LTM-OKAY 9 | ma1-mp-int1/mp-digit/value: #"^(21)" 10 | ma1-mp-int1/sign: LTM-NEG 11 | ma1-mp-int1/used: 1 12 | ma1-mp-int2: declare LTM-int! 13 | response: LTM-init ma1-mp-int2 14 | --assert response = LTM-OKAY 15 | response: LTM-abs ma1-mp-int1 ma1-mp-int2 16 | --assert response = LTM-OKAY 17 | --assert ma1-mp-int1/used = 1 18 | --assert ma1-mp-int1/sign = LTM-NEG 19 | --assert ma1-mp-int1/alloc = LTM-PREC 20 | --assert ma1-mp-int1/mp-digit/value = #"^(021)" 21 | --assert ma1-mp-int2/used = 1 22 | --assert ma1-mp-int2/sign = LTM-ZPOS 23 | --assert ma1-mp-int2/alloc = LTM-PREC 24 | --assert ma1-mp-int2/mp-digit/value = #"^(021)" 25 | 26 | --test-- "ma2" 27 | ma2-mp-int1: declare LTM-int! 28 | response: LTM-init ma2-mp-int1 29 | --assert response = LTM-OKAY 30 | ma2-mp-int1/mp-digit/value: #"^(21)" 31 | ma2-mp-int1/sign: LTM-ZPOS 32 | ma2-mp-int1/used: 1 33 | ma2-mp-int2: declare LTM-int! 34 | response: LTM-init ma2-mp-int2 35 | --assert response = LTM-OKAY 36 | response: LTM-abs ma2-mp-int1 ma2-mp-int2 37 | --assert response = LTM-OKAY 38 | --assert ma2-mp-int2/used = 1 39 | --assert ma2-mp-int2/sign = LTM-ZPOS 40 | --assert ma2-mp-int2/alloc = LTM-PREC 41 | --assert ma2-mp-int2/mp-digit/value = #"^(021)" 42 | 43 | ===end-group=== 44 | -------------------------------------------------------------------------------- /LibTom/LTM-add.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "High level addition" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-add: func [ 12 | "high level addition" 13 | a [LTM-int!] "The first integer of the addition" 14 | b [LTM-int!] "The second" 15 | c [LTM-int!] "The result of the addition" 16 | return: [integer!] "LTM-OKAY or an error code" 17 | /local 18 | response [integer!] ;; call response code 19 | size-a [integer!] ;; size of first integer 20 | size-b [integer!] ;; size of second integer 21 | ][ 22 | 23 | ;; get sign of both inputs 24 | sign-a: a/sign 25 | sign-b: b/sign 26 | 27 | either sign-a = sign-b [ 28 | ;; add the two numbers if they have the same sign 29 | c/sign: sign-a 30 | response: LTM-s-add a b c 31 | ][ 32 | ;; subtract the one with lesser magnitude from the other 33 | ;; take the sign of the larger 34 | ;; note: if the result of the addition is zero, LTM-clamp which is 35 | ;; called by both LTM-s-add and LTM-s-sub will ensure the sign 36 | ;; is set correctly 37 | either LTM-LT = LTM-cmp-mag a b [ 38 | c/sign: sign-b 39 | response: LTM-s-sub b a c 40 | ][ 41 | c/sign: sign-a 42 | response: LTM-s-sub a b c 43 | ] 44 | ] 45 | 46 | response 47 | 48 | ] -------------------------------------------------------------------------------- /DateTime/PWAW-DT-date-to-days.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "A date to days conversion function " 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | 11 | #include %PWAW-DT-date-def.reds 12 | #include %PWAW-DT-days-in-year-todate.reds 13 | #include %PWAW-DT-year-as-days.reds 14 | 15 | PWAW-DT-date-to-days: func [ 16 | { 17 | Converts a date to a number of days since 31/12/1 BC (effectively 31/12/0) 18 | The first acceptable date is 1/1/1 19 | } 20 | d [PWAW-DT-Date!] {a date to be converted} 21 | days [pointer! [integer!]] {number of days} 22 | return: [integer!] {returns: 23 | 24 | 0 - Success 25 | 1 - Year must be 1 or more 26 | 2 - Error in year-as-days 27 | 3 - Error in days-in-year-to-date 28 | } 29 | /local 30 | years-in-days [integer!] 31 | days-in-year [integer!] 32 | 33 | ][ 34 | days-in-year: 0 35 | years-in-days: 0 36 | 37 | if d/year < 1 [ 38 | return 1 39 | ] 40 | 41 | if 0 <> PWAW-DT-year-as-days (d/year - 1) :years-in-days [ 42 | return 2 43 | ] 44 | days-in-year: 0 45 | 46 | if 0 <> PWAW-DT-days-in-year-todate d :days-in-year [ 47 | return 2 48 | ] 49 | days-in-year: days-in-year + 1 ;; include the end day 50 | 51 | days/value: years-in-days + days-in-year 52 | 0 53 | ] 54 | 55 | -------------------------------------------------------------------------------- /DateTime/Tests/year-as-days-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - year-as-days-test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "year as days" 12 | --test-- "yad-1" 13 | i: 0 14 | --assert 0 = PWAW-DT-year-as-days 0 :i 15 | --assert 0 = i 16 | 17 | --test-- "yad-2" 18 | i: 0 19 | --assert 0 = PWAW-DT-year-as-days 1 :i 20 | --assert 365 = i 21 | 22 | --test-- "yad-3" 23 | i: 0 24 | --assert 0 = PWAW-DT-year-as-days 3 :i 25 | --assert 1095 = i 26 | 27 | --test-- "yad-4" 28 | i: 0 29 | --assert 0 = PWAW-DT-year-as-days 4 :i 30 | --assert 1461 = i 31 | 32 | --test-- "yad-5" 33 | i: 0 34 | --assert 0 = PWAW-DT-year-as-days 100 :i 35 | --assert 36524 = i 36 | 37 | --test-- "yad-6" 38 | i: 0 39 | --assert 0 = PWAW-DT-year-as-days 2000 :i 40 | --assert 730482 = i 41 | 42 | --test-- "yad-7" 43 | i: 0 44 | --assert 0 = PWAW-DT-year-as-days 2001 :i 45 | --assert 730847 = i 46 | 47 | --test-- "yad-8" 48 | i: 0 49 | --assert 0 = PWAW-DT-year-as-days 2012 :i 50 | --assert 734865 = i 51 | 52 | --test-- "yad-9" 53 | i: 0 54 | --assert 0 = PWAW-DT-year-as-days 2013 :i 55 | --assert 735230 = i 56 | 57 | --test-- "yad-10" 58 | i: 0 59 | --assert 0 = PWAW-DT-year-as-days 2014 :i 60 | --assert 735595 = i 61 | 62 | ~~~end-file~~~ 63 | 64 | -------------------------------------------------------------------------------- /LibTom/LTM-lshd.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Shift left a number of digits" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-lshd: func [ 12 | "Shift left a number of digits" 13 | mp-int [LTM-int!] "The integer to be left shifted" 14 | shift [integer!] "Number of digits to be shifted" 15 | return: [integer!] "LTM-OKAY or an error code" 16 | /local 17 | new-slot [integer!] ;; used to shift digits 18 | old-slot [integer!] ;; used to shift digits 19 | response [integer!] ;;Response code from func calls 20 | ][ 21 | ;; if shift is 0 or less, there is nothing to do 22 | if shift < 1 [return LTM-OKAY] 23 | 24 | ;; grow the size of the int if necessary 25 | if mp-int/used + shift > mp-int/alloc [ 26 | response: LTM-grow mp-int mp-int/used + shift 27 | if response <> LTM-OKAY [return response] 28 | ] 29 | 30 | ;; copy the digits to their new position, starting with most significant 31 | ;; and set the used to reflect the shift 32 | old-slot: mp-int/used 33 | mp-int/used: mp-int/used + shift 34 | new-slot: mp-int/used 35 | while [old-slot > 0][ 36 | mp-int/mp-digit/new-slot: mp-int/mp-digit/old-slot 37 | new-slot: new-slot - 1 38 | old-slot: old-slot - 1 39 | ] 40 | 41 | ;; zero the lower digits 42 | LTM-zero-set(mp-int/mp-digit 1 shift) 43 | 44 | LTM-OKAY 45 | ] -------------------------------------------------------------------------------- /DateTime/PWAW-DT-later.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Checks a date & time is later than another" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-DT-date-def.reds 11 | #include %PWAW-DT-UTC.reds 12 | 13 | PWAW-DT-later?: func [ 14 | d1 [PWAW-DT-date!] 15 | d2 [PWAW-DT-date!] 16 | return: [logic!] 17 | /local 18 | utc-d1 [PWAW-DT-date!] 19 | utc-d2 [PWAW-DT-date!] 20 | 21 | ][ 22 | utc-d1: declare PWAW-DT-date! 23 | utc-d2: declare PWAW-DT-date! 24 | if 0 <> PWAW-DT-UTC d1 utc-d1 [return false] 25 | if 0 <> PWAW-DT-UTC d2 utc-d2 [return false] 26 | 27 | if utc-d1/year > utc-d2/year [return true] 28 | if utc-d1/year < utc-d2/year [return false] 29 | if utc-d1/month > utc-d2/month [return true] 30 | if utc-d1/month < utc-d2/month [return false] 31 | if utc-d1/day > utc-d2/day [return true] 32 | if utc-d1/day < utc-d2/day [return false] 33 | if utc-d1/hour > utc-d2/hour [return true] 34 | if utc-d1/hour < utc-d2/hour [return false] 35 | if utc-d1/minutes > utc-d2/minutes [return true] 36 | if utc-d1/minutes < utc-d2/minutes [return false] 37 | if utc-d1/seconds > utc-d2/seconds [return true] 38 | if utc-d1/seconds < utc-d2/seconds [return false] 39 | either utc-d1/microseconds > utc-d2/microseconds [ 40 | true 41 | ][ 42 | false 43 | ] 44 | 45 | ] 46 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-rshd-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "right shift digits" 4 | 5 | --test-- "mp-rshd1" 6 | mp-rshd1-int: declare LTM-int! 7 | response: LTM-init mp-rshd1-int 8 | --assert response = LTM-OKAY 9 | mp-rshd1-int/used: 5 10 | mp-rshd1-int/mp-digit/1: as LTM-digit! 123 11 | mp-rshd1-int/mp-digit/2: as LTM-digit! 124 12 | mp-rshd1-int/mp-digit/3: as LTM-digit! 125 13 | mp-rshd1-int/mp-digit/4: as LTM-digit! 126 14 | mp-rshd1-int/mp-digit/5: as LTM-digit! 127 15 | response: LTM-rshd mp-rshd1-int 1 16 | --assert response = LTM-OKAY 17 | --assert mp-rshd1-int/used = 4 18 | --assert mp-rshd1-int/mp-digit/1 = as LTM-digit! 124 19 | --assert mp-rshd1-int/mp-digit/2 = as LTM-digit! 125 20 | --assert mp-rshd1-int/mp-digit/3 = as LTM-digit! 126 21 | --assert mp-rshd1-int/mp-digit/4 = as LTM-digit! 127 22 | 23 | --test-- "mp-rshd2" 24 | mp-rshd2-int: declare LTM-int! 25 | response: LTM-init mp-rshd2-int 26 | --assert response = LTM-OKAY 27 | mp-rshd2-int/used: 4 28 | mp-rshd2-int/mp-digit/1: as LTM-digit! 124 29 | mp-rshd2-int/mp-digit/2: as LTM-digit! 125 30 | mp-rshd2-int/mp-digit/3: as LTM-digit! 126 31 | mp-rshd2-int/mp-digit/4: as LTM-digit! 127 32 | response: LTM-rshd mp-rshd2-int 0 33 | --assert response = LTM-OKAY 34 | --assert mp-rshd2-int/used = 4 35 | --assert mp-rshd2-int/mp-digit/1 = as LTM-digit! 124 36 | --assert mp-rshd2-int/mp-digit/2 = as LTM-digit! 125 37 | --assert mp-rshd2-int/mp-digit/3 = as LTM-digit! 126 38 | --assert mp-rshd2-int/mp-digit/4 = as LTM-digit! 127 39 | 40 | ===end-group=== 41 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-lshd-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "left shift digits" 4 | 5 | --test-- "mp-lshd1" 6 | mp-lshd1-int: declare LTM-int! 7 | response: LTM-init mp-lshd1-int 8 | --assert response = LTM-OKAY 9 | mp-lshd1-int/used: 4 10 | mp-lshd1-int/mp-digit/1: as LTM-digit! 124 11 | mp-lshd1-int/mp-digit/2: as LTM-digit! 125 12 | mp-lshd1-int/mp-digit/3: as LTM-digit! 126 13 | mp-lshd1-int/mp-digit/4: as LTM-digit! 127 14 | response: LTM-lshd mp-lshd1-int 1 15 | --assert response = LTM-OKAY 16 | --assert mp-lshd1-int/used = 5 17 | --assert mp-lshd1-int/mp-digit/1 = as LTM-digit! 0 18 | --assert mp-lshd1-int/mp-digit/2 = as LTM-digit! 124 19 | --assert mp-lshd1-int/mp-digit/3 = as LTM-digit! 125 20 | --assert mp-lshd1-int/mp-digit/4 = as LTM-digit! 126 21 | --assert mp-lshd1-int/mp-digit/5 = as LTM-digit! 127 22 | 23 | --test-- "mp-lshd2" 24 | mp-lshd2-int: declare LTM-int! 25 | response: LTM-init mp-lshd2-int 26 | --assert response = LTM-OKAY 27 | mp-lshd2-int/used: 4 28 | mp-lshd2-int/mp-digit/1: as LTM-digit! 124 29 | mp-lshd2-int/mp-digit/2: as LTM-digit! 125 30 | mp-lshd2-int/mp-digit/3: as LTM-digit! 126 31 | mp-lshd2-int/mp-digit/4: as LTM-digit! 127 32 | response: LTM-lshd mp-lshd2-int 0 33 | --assert response = LTM-OKAY 34 | --assert mp-lshd2-int/used = 4 35 | --assert mp-lshd2-int/mp-digit/1 = as LTM-digit! 124 36 | --assert mp-lshd2-int/mp-digit/2 = as LTM-digit! 125 37 | --assert mp-lshd2-int/mp-digit/3 = as LTM-digit! 126 38 | --assert mp-lshd2-int/mp-digit/4 = as LTM-digit! 127 39 | 40 | ===end-group=== 41 | -------------------------------------------------------------------------------- /LibTom/LTM-init-multi.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Initalises multiple new mp-ints" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-init-multi: func [ 12 | "Initalises multiple new mp-ints" 13 | [typed] 14 | count [integer!] 15 | list [typed-value!] ;; list of mp-ints 16 | return: [integer!] 17 | /local 18 | i [integer!] 19 | j [integer!] 20 | tmp-list [typed-value!] 21 | ][ 22 | 23 | ;; check that type of the mp-ints to be initalised 24 | ;; Red/System version 1 only allows checking that it is an alias 25 | i: 0 26 | tmp-list: list 27 | until [ 28 | i: i + 1 29 | if not alias? tmp-list/type [return LTM-INVALID-ARGS] 30 | tmp-list: tmp-list + 1 31 | 32 | i = count 33 | ] 34 | 35 | ;; initialise the mp-ints, if a failure is encountered clear any 36 | ;; previously initialised mp-ints 37 | i: 0 38 | tmp-list: list 39 | until [ 40 | i: i + 1 41 | if LTM-OKAY <> LTM-init as LTM-int! tmp-list/value [ 42 | ;; clear any mp-ints that were successfully initalised 43 | if i > 1 [ 44 | j: 1 45 | until [ 46 | LTM-clear as LTM-int! list/value 47 | list: list + 1 48 | j: j + 1 49 | j = i 50 | ] 51 | ] 52 | return LTM-MEM 53 | ] 54 | 55 | tmp-list: tmp-list + 1 56 | i = count 57 | ] 58 | 59 | LTM-OKAY 60 | ] -------------------------------------------------------------------------------- /LibTom/LTM-s-mul-digs.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: {multiples absolute values of two integers 3 | only computes up to the number of digits supplied in args } 4 | Author: "PeterWAWood" 5 | Version: 0.1.0 6 | License: {Distributed under the Boost Software License, Version 1.0. 7 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 8 | ] 9 | 10 | #include %libtommaths.def 11 | 12 | LTM-s-mul-digs: func [ 13 | {multiples absolute values of two integers 14 | only computes up to the number of digits supplied in args } 15 | a [LTM-int!] "First integer" 16 | b [LTM-int!] "Second integer" 17 | c [LTM-int!] "The result" 18 | digits [integer!] " Number of digits to be computed" 19 | return: [integer!] "LTM-OKAY or an error code" 20 | /local 21 | carry [LTM-digit!] ;; carry digit 22 | ia [integer!] ;; counter 23 | ib [integer!] ;; counter 24 | min [integer!] ;; min number of digits 25 | max [integer!] ;; max number of digits 26 | oldused [integer!] ;; value of c/used at start 27 | response [integer!] ;; call response code 28 | t [LTM-int!] ;; t 29 | ][ 30 | 31 | ;; can the fast multiplier be used 32 | ;; code to be added later 33 | 34 | 35 | ;; allocate a temporary MP-int of the size requested 36 | response: LTM-init-size t digits 37 | if response <> LTM-OKAY [ 38 | return response 39 | ] 40 | t/used: digits 41 | 42 | ;; compute the digits of the product directly 43 | ix: 1 44 | until [ 45 | 46 | 47 | ix: ix + 1 48 | ix < a/used 49 | ] 50 | 51 | 52 | LTM-OKAY 53 | ] 54 | -------------------------------------------------------------------------------- /I64/PWAW-I64-abs-mul.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Multiplies the absolute values of two 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-abs-add.reds 12 | #include %PWAW-I64-shift-left.reds 13 | 14 | PWAW-I64-abs-mul: func [ 15 | a [PWAW-I64-int64!] 16 | b [PWAW-I64-int64!] 17 | c [PWAW-I64-int64!] 18 | return: [integer!] 19 | /local 20 | i [integer!] 21 | resp [integer!] 22 | temp1 [PWAW-I64-int64!] 23 | temp2 [PWAW-I64-int64!] 24 | temp3 [PWAW-I64-int64!] 25 | ][ 26 | temp1: declare PWAW-I64-int64! 27 | temp2: declare PWAW-I64-int64! 28 | temp3: declare PWAW-I64-int64! 29 | 30 | PWAW-I64-zero-int64(c) 31 | 32 | if any [ 33 | PWAW-I64-zero?(a) 34 | PWAW-I64-zero?(b) 35 | ][ 36 | return PWAW-I64-OKAY 37 | ] 38 | 39 | PWAW-I64-copy(b temp1) 40 | i: 1 41 | until [ 42 | resp: PWAW-I64-shift-left c temp2 1 43 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 44 | either 40000000h = (temp1/most-sig and 40000000h) [ 45 | resp: PWAW-I64-abs-add a temp2 c 46 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 47 | ][ 48 | PWAW-I64-copy(temp2 c) 49 | ] 50 | resp: PWAW-I64-shift-left temp1 temp3 1 51 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 52 | PWAW-I64-copy(temp3 temp1) 53 | i: i + 1 54 | i > 63 55 | ] 56 | 57 | PWAW-I64-OKAY 58 | 59 | ] 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /DateTime/Tests/UTC-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - date-difference test script" 3 | Author: "Peter W A Wood" 4 | 5 | Rights: "Copyright (C) 2012-2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-DT-date-time.reds 11 | 12 | ~~~start-file~~~ "UTC" 13 | 14 | dd-date: declare PWAW-DT-date! 15 | dd-UTC: declare PWAW-DT-date! 16 | 17 | --test-- "dd-1" 18 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date 19 | --assert 0 = PWAW-DT-UTC dd-date dd-UTC 20 | --assert dd-UTC/year = 2012 21 | --assert dd-UTC/month = 1 22 | --assert dd-UTC/day = 13 23 | --assert dd-UTC/hour = 8 24 | --assert dd-UTC/minutes = 16 25 | --assert dd-UTC/seconds = 27 26 | --assert dd-UTC/microseconds = 0 27 | 28 | --test-- "dd-2" 29 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:16:27+08:30" dd-date 30 | --assert 0 = PWAW-DT-UTC dd-date dd-UTC 31 | --assert dd-UTC/year = 2012 32 | --assert dd-UTC/month = 1 33 | --assert dd-UTC/day = 13 34 | --assert dd-UTC/hour = 7 35 | --assert dd-UTC/minutes = 46 36 | --assert dd-UTC/seconds = 27 37 | --assert dd-UTC/microseconds = 0 38 | 39 | --test-- "dd-3" 40 | dd-r: PWAW-DT-load-date "13-Jan-2012/07:46:27+08:30" dd-date 41 | --assert 0 = PWAW-DT-UTC dd-date dd-UTC 42 | --assert dd-UTC/year = 2012 43 | --assert dd-UTC/month = 1 44 | --assert dd-UTC/day = 12 45 | --assert dd-UTC/hour = 23 46 | --assert dd-UTC/minutes = 16 47 | --assert dd-UTC/seconds = 27 48 | --assert dd-UTC/microseconds = 0 49 | 50 | ~~~end-file~~~ 51 | 52 | -------------------------------------------------------------------------------- /Core/Tests/load-int-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - str-int? test script" 3 | Author: "Peter W A Wood" 4 | File: %load-int-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "load-int" 13 | 14 | li: 0 15 | 16 | --test-- "li-1" 17 | li: 0 18 | --assert 0 = PWAW-C-load-int "1" :li 19 | --assert 1 = li 20 | 21 | --test-- "li-2" 22 | li: 999 23 | --assert 0 = PWAW-C-load-int "0" :li 24 | --assert 0 = li 25 | 26 | --test-- "li-3" 27 | li: 0 28 | --assert 0 = PWAW-C-load-int "-1" :li 29 | --assert -1 = li 30 | 31 | --test-- "li-4" 32 | li: 0 33 | --assert 0 = PWAW-C-load-int "2147483647" :li 34 | --assert 2147483647 = li 35 | 36 | --test-- "li-5" 37 | li: 0 38 | --assert 0 = PWAW-C-load-int "-2147483648" :li 39 | --assert -2147483648 = li 40 | 41 | --test-- "li-6" ;; to document what happens 42 | li: 0 43 | --assert 1 = PWAW-C-load-int "2147483648" :li 44 | --assert 0 = li 45 | 46 | --test-- "li-7" ;; to document what happens 47 | li: 0 48 | --assert 1 = PWAW-C-load-int "-2147483649" :li 49 | --assert 0 = li 50 | 51 | --test-- "li-8" 52 | li: 999 53 | --assert 1 = PWAW-C-load-int "-" :li 54 | 55 | --test-- "li-9" 56 | li: 0 57 | --assert 0 = PWAW-C-load-int "+1" :li 58 | --assert 1 = li 59 | 60 | --test-- "li-10" 61 | li: 0 62 | --assert 1 = PWAW-C-load-int "abcde" :li 63 | 64 | ~~~end-file~~~ 65 | 66 | -------------------------------------------------------------------------------- /Core/Tests/str-int-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - str-int? test script" 3 | Author: "Peter W A Wood" 4 | File: %str-int-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "str-int?" 13 | 14 | --test-- "si-1" 15 | --assert PWAW-C-str-int? "1" 16 | 17 | --test-- "si-2" 18 | --assert not PWAW-C-str-int? "a" 19 | 20 | --test-- "si-3" 21 | --assert PWAW-C-str-int? "-1" 22 | 23 | --test-- "si-4" 24 | --assert not PWAW-C-str-int? "-" 25 | 26 | --test-- "si-5" 27 | --assert PWAW-C-str-int? "1234567890" 28 | 29 | --test-- "si-6" 30 | --assert PWAW-C-str-int? "-1234567890" 31 | 32 | --test-- "si-7" 33 | --assert not PWAW-C-str-int? "123456789O" 34 | 35 | --test-- "si-8" 36 | --assert not PWAW-C-str-int? "!234567890" 37 | 38 | --test-- "si-9" 39 | --assert not PWAW-C-str-int? "123cd67890" 40 | 41 | --test-- "si-10" 42 | --assert PWAW-C-str-int? "2147483647" 43 | 44 | --test-- "si-11" 45 | --assert PWAW-C-str-int? "+2147483647" 46 | 47 | --test-- "si-12" 48 | --assert PWAW-C-str-int? "-2147483648" 49 | 50 | --test-- "si-13" 51 | --assert not PWAW-C-str-int? "2147483648" 52 | 53 | --test-- "si-14" 54 | --assert not PWAW-C-str-int? "-2147483649" 55 | 56 | --test-- "si-15" 57 | --assert not PWAW-C-str-int? "2147483657" 58 | 59 | --test-- "si-16" 60 | --assert PWAW-C-str-int? "+1" 61 | 62 | --test-- "si-17" 63 | --assert not PWAW-C-str-int? "+" 64 | 65 | ~~~end-file~~~ 66 | 67 | -------------------------------------------------------------------------------- /LibTom/LTM-mod-2d.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Gives the remainder when dividing an integer by a power of 2" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | #include %LTM-clear.reds 11 | #include %LTM-copy.reds 12 | #include %LTM-zero.reds 13 | 14 | LTM-mod-2d: func [ 15 | { calculate a mod 2**b} 16 | a [LTM-int!] "The integer to be dvided" 17 | b [integer!] "Shift count" 18 | c [LTM-int!] "Remainder" 19 | return: [integer!] "LTM-OKAY or an error code" 20 | /local 21 | i [integer!] ;; array index 22 | mask [LTM-digit!] ;; bit mask 23 | res [integer!] ;; response code from library calls 24 | ][ 25 | 26 | ;; if the shift count is 0 or less, set remainder to zero 27 | if b < 1 [ 28 | res: LTM-zero c 29 | return res 30 | ] 31 | 32 | ;; copy the value 33 | res: LTM-copy a c 34 | if res <> LTM-OKAY [return res] 35 | 36 | ;;if the modulus is larger than the value, return the value 37 | if b >= (a/used * LTM-DIGIT-BIT) [return LTM-OKAY] 38 | 39 | ;; zero the digits above the last digit of the modulus 40 | i: (b / LTM-DIGIT-BIT) + 1 41 | if b % LTM-DIGIT-BIT > 0 [i: i + 1] 42 | 43 | until [ 44 | c/mp-digit/i: LTM-ZERO-DIGIT 45 | i: i + 1 46 | i > c/used 47 | ] 48 | 49 | ;; clear the digit where the remainder digits start 50 | i: (b / LTM-DIGIT-BIT) + 1 51 | mask: (LTM-ONE-DIGIT << (as LTM-digit! b)) - LTM-ONE-DIGIT 52 | c/mp-digit/i: c/mp-digit/i and mask 53 | 54 | res: LTM-clamp c 55 | 56 | return res 57 | ] -------------------------------------------------------------------------------- /I64/PWAW-I64-int64-def.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Int64 Structure Definition" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-I64-int64!: alias struct! [ 11 | least-sig [integer!] 12 | most-sig [integer!] 13 | ] 14 | 15 | #define PWAW-I64-OKAY 0 16 | #define PWAW-I64-OVERFLOW 1 ;; an int64 overflowed 17 | #define PWAW-I64-INVALID-ARG 2 18 | #define PWAW-I64-EXCESSIVE-SHIFT 3 19 | #define PWAW-I64-ZERO-DIVIDE 4 20 | 21 | #define PWAW-I64-copy(a b) [ 22 | b/least-sig: a/least-sig 23 | b/most-sig: a/most-sig 24 | ] 25 | 26 | #define PWAW-I64-equal?(a b) [ 27 | all [ 28 | a/least-sig = b/least-sig 29 | a/most-sig = b/most-sig 30 | ] 31 | ] 32 | 33 | #define PWAW-I64-negative?(i64) [ 34 | (i64/most-sig < 0) 35 | ] 36 | 37 | #define PWAW-I64-positive?(i64) [ 38 | (i64/most-sig >= 0) 39 | ] 40 | 41 | #define PWAW-I64-return-if(a op b) [ 42 | if a op b [ 43 | return a 44 | ] 45 | ] 46 | 47 | #define PWAW-I64-zero?(a) [ 48 | all [ 49 | 0 = a/least-sig 50 | 0 = a/most-sig 51 | ] 52 | ] 53 | 54 | #define PWAW-I64-zero-int64(i64) [ 55 | i64/least-sig: 0 56 | i64/most-sig: 0 57 | ] 58 | 59 | PWAW-I64-zero: declare PWAW-I64-int64! 60 | PWAW-I64-zero/least-sig: 0 61 | PWAW-I64-zero/most-sig: 0 62 | 63 | PWAW-I64-one: declare PWAW-I64-int64! 64 | PWAW-I64-one/least-sig: 1 65 | PWAW-I64-one/most-sig: 0 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-clamp-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-clamp" 4 | --test-- "mcl1" 5 | mcl1-mp-int: declare LTM-int! 6 | response: LTM-init mcl1-mp-int 7 | --assert response = LTM-OKAY 8 | mcl1-mp-int/used: 4 9 | mcl1-mp-int/sign: LTM-NEG 10 | response: LTM-clamp mcl1-mp-int 11 | --assert response = LTM-OKAY 12 | --assert mcl1-mp-int/used = 0 13 | --assert mcl1-mp-int/alloc = LTM-PREC 14 | --assert mcl1-mp-int/sign = LTM-ZPOS 15 | --assert mcl1-mp-int/mp-digit <> as byte-ptr! 0 16 | response: LTM-clear mcl1-mp-int 17 | --assert response = LTM-OKAY 18 | 19 | --test-- "mcl2" 20 | mcl2-mp-int: declare LTM-int! 21 | response: LTM-init mcl2-mp-int 22 | --assert response = LTM-OKAY 23 | mcl2-mp-int/used: 4 24 | mcl2-mp-int/sign: LTM-ZPOS 25 | mcl2-mp-int/mp-digit/value: #"^(01)" 26 | response: LTM-clamp mcl2-mp-int 27 | --assert response = LTM-OKAY 28 | --assert mcl2-mp-int/used = 1 29 | --assert mcl2-mp-int/sign = LTM-ZPOS 30 | --assert mcl2-mp-int/alloc = LTM-PREC 31 | --assert mcl2-mp-int/mp-digit/value = #"^(01)" 32 | response: LTM-clear mcl2-mp-int 33 | --assert response = LTM-OKAY 34 | 35 | --test-- "mcl3" 36 | mcl3-mp-int: declare LTM-int! 37 | response: LTM-init mcl3-mp-int 38 | --assert response = LTM-OKAY 39 | mcl3-mp-int/used: 1 40 | mcl3-mp-int/sign: LTM-ZPOS 41 | mcl3-mp-int/mp-digit/value: #"^(0F)" 42 | response: LTM-clamp mcl3-mp-int 43 | --assert response = LTM-OKAY 44 | --assert mcl3-mp-int/used = 1 45 | --assert mcl3-mp-int/sign = LTM-ZPOS 46 | --assert mcl3-mp-int/alloc = LTM-PREC 47 | --assert mcl3-mp-int/mp-digit/value = #"^(0F)" 48 | response: LTM-clear mcl3-mp-int 49 | --assert response = LTM-OKAY 50 | 51 | ===end-group=== 52 | -------------------------------------------------------------------------------- /I64/Tests/greater-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - greater test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-greater.reds 10 | 11 | ~~~start-file~~~ "greater?" 12 | 13 | --test-- "greater-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 1 16 | a/most-sig: 1 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 0 19 | b/most-sig: 1 20 | --assert PWAW-I64-greater? a b 21 | --assert a/least-sig = 1 22 | --assert b/least-sig = 0 23 | --assert a/most-sig = 1 24 | --assert b/most-sig = 1 25 | 26 | --test-- "greater-2" 27 | a: declare PWAW-I64-int64! 28 | a/least-sig: FFFFFFFFh 29 | a/most-sig: 0 30 | b: declare PWAW-I64-int64! 31 | b/least-sig: 0 32 | b/most-sig: 1 33 | --assert not PWAW-I64-greater? a b 34 | 35 | --test-- "greater-3" 36 | a: declare PWAW-I64-int64! 37 | a/least-sig: 1 38 | a/most-sig: 0 39 | b: declare PWAW-I64-int64! 40 | b/least-sig: 1 41 | b/most-sig: 0 42 | --assert not PWAW-I64-greater? a b 43 | 44 | --test-- "greater-4" 45 | a: declare PWAW-I64-int64! 46 | a/least-sig: 40000000h 47 | a/most-sig: 0 48 | b: declare PWAW-I64-int64! 49 | b/least-sig: 49F49F4Ah 50 | b/most-sig: 0 51 | --assert not PWAW-I64-greater? a b 52 | 53 | --test-- "greater-5" 54 | a: declare PWAW-I64-int64! 55 | a/least-sig: A0000000h 56 | a/most-sig: 0 57 | b: declare PWAW-I64-int64! 58 | b/least-sig: 49F49F4Ah 59 | b/most-sig: 0 60 | --assert PWAW-I64-greater? a b 61 | 62 | ~~~end-file~~~ 63 | 64 | -------------------------------------------------------------------------------- /LibTom/Tests/libtommaths-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Lib Tom aths tests" 3 | Author: "Peter W A Wood" 4 | File: %libtommaths-test.reds 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../../../../Languages/Red/quick-test/quick-test.reds 10 | #include %../libtommaths.reds 11 | 12 | print-digits: func [ 13 | mp-int [LTM-int!] 14 | /local 15 | bp [LTM-digit-ptr!] 16 | i [integer!] 17 | ][ 18 | print ["The digits (least significant first) are:" lf] 19 | bp: mp-int/mp-digit 20 | i: 0 21 | while [i < mp-int/used][ 22 | print [as integer! bp/value lf] 23 | i: i + 1 24 | bp: bp + 1 25 | ] 26 | ] 27 | 28 | ~~~start-file~~~ "lib tom maths" 29 | 30 | #include %mp-abs-group.reds 31 | #include %mp-add-group.reds 32 | #include %mp-clamp-group.reds 33 | #include %mp-clear-group.reds 34 | #include %mp-cmp-mag-group.reds 35 | #include %mp-compare-group.reds 36 | #include %mp-copy-group.reds 37 | #include %mp-copy-init-group.reds 38 | #include %mp-div-2-group.reds 39 | #include %mp-div-2d-group.reds 40 | #include %mp-grow-group.reds 41 | #include %mp-init-group.reds 42 | #include %mp-init-multi-group.reds 43 | #include %mp-init-size-group.reds 44 | #include %mp-lshb-group.reds 45 | #include %mp-lshd-group.reds 46 | #include %mp-mod-2d-group.reds 47 | #include %mp-mul-2-group.reds 48 | #include %mp-neg-group.reds 49 | #include %mp-rshd-group.reds 50 | #include %mp-set-group.reds 51 | #include %mp-set-int-group.reds 52 | #include %mp-sub-group.reds 53 | #include %mp-s-add-group.reds 54 | #include %mp-s-sub-group.reds 55 | #include %mp-zero-group.reds 56 | 57 | ~~~end-file~~~ 58 | 59 | -------------------------------------------------------------------------------- /Core/Tests/mold-int-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - mold-int test script" 3 | Author: "Peter W A Wood" 4 | File: %mold-int-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-C-core.reds 11 | 12 | ~~~start-file~~~ "mold-int" 13 | 14 | --test-- "mi-1" 15 | mi: "abcdefghijk" 16 | --assert 0 = PWAW-C-mold-int 0 mi 17 | --assert PWAW-C-str-equal? "0" mi 18 | 19 | --test-- "mi-2" 20 | mi: "" 21 | --assert 1 = PWAW-C-mold-int 0 mi 22 | --assert PWAW-C-str-equal? "" mi 23 | 24 | --test-- "mi-3" 25 | mi: "abcdefghijk" 26 | --assert 0 = PWAW-C-mold-int -2147483648 mi 27 | --assert PWAW-C-str-equal? "-2147483648" mi 28 | print [mi lf] 29 | 30 | --test-- "mi-4" 31 | mi: "abcdefghij" 32 | --assert 1 = PWAW-C-mold-int -2147483648 mi 33 | --assert PWAW-C-str-equal? "abcdefghij" mi 34 | 35 | --test-- "mi-5" 36 | mi: "abcdefghijk" 37 | --assert 0 = PWAW-C-mold-int 2147483647 mi 38 | --assert PWAW-C-str-equal? "2147483647" mi 39 | 40 | --test-- "mi-6" 41 | mi: "abcdefghijk" 42 | --assert 0 = PWAW-C-mold-int 1 mi 43 | --assert PWAW-C-str-equal? "1" mi 44 | 45 | --test-- "mi-7" 46 | mi: "abcdefghijk" 47 | --assert 0 = PWAW-C-mold-int -1 mi 48 | --assert PWAW-C-str-equal? "-1" mi 49 | 50 | --test-- "mi-8" 51 | mi: "abcdefghijk" 52 | --assert 0 = PWAW-C-mold-int 10 mi 53 | --assert PWAW-C-str-equal? "10" mi 54 | 55 | --test-- "mi-9" 56 | mi: "abcdefghijk" 57 | --assert 0 = PWAW-C-mold-int -5 mi 58 | --assert PWAW-C-str-equal? "-5" mi 59 | 60 | ~~~end-file~~~ 61 | 62 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-neg-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-neg" 4 | 5 | --test-- "mn1" 6 | mn1-mp-int1: declare LTM-int! 7 | response: LTM-init mn1-mp-int1 8 | --assert response = LTM-OKAY 9 | mn1-mp-int1/mp-digit/value: #"^(21)" 10 | mn1-mp-int1/sign: LTM-NEG 11 | mn1-mp-int1/used: 1 12 | mn1-mp-int2: declare LTM-int! 13 | response: LTM-init mn1-mp-int2 14 | --assert response = LTM-OKAY 15 | response: LTM-negate mn1-mp-int1 mn1-mp-int2 16 | --assert response = LTM-OKAY 17 | --assert mn1-mp-int1/used = 1 18 | --assert mn1-mp-int1/sign = LTM-NEG 19 | --assert mn1-mp-int1/alloc = LTM-PREC 20 | --assert mn1-mp-int1/mp-digit/value = #"^(021)" 21 | --assert mn1-mp-int2/used = 1 22 | --assert mn1-mp-int2/sign = LTM-ZPOS 23 | --assert mn1-mp-int2/alloc = LTM-PREC 24 | --assert mn1-mp-int2/mp-digit/value = #"^(021)" 25 | 26 | --test-- "mn2" 27 | mn2-mp-int1: declare LTM-int! 28 | response: LTM-init mn2-mp-int1 29 | --assert response = LTM-OKAY 30 | mn2-mp-int1/mp-digit/value: #"^(21)" 31 | mn2-mp-int1/sign: LTM-ZPOS 32 | mn2-mp-int1/used: 1 33 | mn2-mp-int2: declare LTM-int! 34 | response: LTM-init mn2-mp-int2 35 | --assert response = LTM-OKAY 36 | response: LTM-negate mn2-mp-int1 mn2-mp-int2 37 | --assert response = LTM-OKAY 38 | --assert mn2-mp-int2/used = 1 39 | --assert mn2-mp-int2/sign = LTM-NEG 40 | --assert mn2-mp-int2/alloc = LTM-PREC 41 | --assert mn2-mp-int2/mp-digit/value = #"^(021)" 42 | 43 | --test-- "mn3" 44 | mn3-mp-int1: declare LTM-int! 45 | response: LTM-init mn3-mp-int1 46 | --assert response = LTM-OKAY 47 | response: LTM-negate mn3-mp-int1 mn3-mp-int1 48 | --assert response = LTM-OKAY 49 | --assert mn3-mp-int1/sign = LTM-ZPOS 50 | --assert mn3-mp-int1/used = 0 51 | 52 | ===end-group=== 53 | -------------------------------------------------------------------------------- /LibTom/LTM-set-int.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Sets a mp-int from a 32-bit integer" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | #include %LTM-clamp.reds 11 | #include %LTM-mul-2d.reds 12 | #include %LTM-zero.reds 13 | 14 | LTM-set-int: func [ 15 | "Sets a mp-int to a 32-bit integer" 16 | mp-int [LTM-int!] "The mp integer to be set" 17 | int [integer!] "The integer" 18 | return: [integer!] "LTM-OKAY or an error code" 19 | /local 20 | i [integer!] ;; loop counter 21 | j [integer!] ;; temp 22 | k [integer!] ;; temp 23 | response [integer!] ;; response from lib calls 24 | ][ 25 | 26 | LTM-zero mp-int 27 | 28 | ;; set the mp-int four bits at a time ie 8 iterations 29 | i: 1 30 | until [ 31 | 32 | ;; shift the number four bits to the left 33 | response: LTM-mul-2d mp-int 4 mp-int 34 | 35 | if response <> LTM-OKAY [return response] 36 | 37 | ;; OR in the top four bits of the source 38 | k: int >>> 28 ;; These two statements are required 39 | j: 15 and k ;; due to unexpected result if they 40 | ;; are removed. 41 | mp-int/mp-digit/value: mp-int/mp-digit/value or (as LTM-digit! j) 42 | 43 | ;; shift the next four bits to the front of the integer 44 | int: int << 4 45 | 46 | ;; increase used count on each iteration to be absolutely certain 47 | ;; nothing gets throw away by clamp (which is called in mul-2d) 48 | mp-int/used: mp-int/used + 1 49 | 50 | i: i + 1 51 | i > 8 52 | ] 53 | 54 | ;; remove leading zeros from the mp-int 55 | LTM-clamp mp-int ;; returns LTM-OKAY 56 | 57 | ] -------------------------------------------------------------------------------- /Core/PWAW-C-mold-int.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Mold an integer" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.1 5 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-C-mold-int: func [ 11 | ;; provides a literal representation of an integer in the supplied string 12 | 13 | i [integer!] 14 | s [c-string!] 15 | return: [integer!] 16 | ;; returns: 17 | ;; 0 - successful conversion 18 | ;; 1 - supplied string too short 19 | 20 | /local 21 | digit [integer!] 22 | digit-printed? [logic!] 23 | divisor [integer!] 24 | len [integer!] 25 | pos [integer!] 26 | rem [integer!] 27 | ][ 28 | len: length? s 29 | divisor: 1000000000 30 | digit-printed?: false 31 | 32 | if i = 0 [ 33 | if len < 1 [return 1] 34 | s/1: #"0" 35 | s/2: null-byte 36 | return 0 37 | ] 38 | if i = -2147483648 [ 39 | if len < 11 [return 1] 40 | s/1: #"-" 41 | s/2: #"2" 42 | s/3: #"1" 43 | s/4: #"4" 44 | s/5: #"7" 45 | s/6: #"4" 46 | s/7: #"8" 47 | s/8: #"3" 48 | s/9: #"6" 49 | s/10: #"4" 50 | s/11: #"8" 51 | s/12: null-byte 52 | return 0 53 | ] 54 | rem: i 55 | pos: 1 56 | if rem < 0 [ 57 | s/pos: #"-" 58 | pos: pos + 1 59 | rem: -1 * rem 60 | ] 61 | until [ 62 | digit: rem / divisor 63 | either digit-printed? [ 64 | s/pos: as byte! (digit + 48) 65 | pos: pos + 1 66 | ][ 67 | if digit <> 0 [ 68 | s/pos: as byte! (digit + 48) 69 | pos: pos + 1 70 | digit-printed?: true 71 | ] 72 | ] 73 | if pos > len [return 1] 74 | rem: rem - (digit * divisor) 75 | divisor: divisor / 10 76 | divisor = 0 77 | ] 78 | s/pos: null-byte 79 | 0 80 | ] 81 | 82 | -------------------------------------------------------------------------------- /UTF8/utf8.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "utf-8" 3 | Author: "Peter W A Wood" 4 | File: %utf-8.reds 5 | Version: 0.0.1 6 | Rights: "Copyright (C) 2011 Peter W A Wood. All rights reserved." 7 | License: "Distributed under the Boost Software License, Version 1.0." 8 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 9 | ] 10 | 11 | PWAW-U-verify: func [ 12 | str [c-string!] 13 | return: [integer!] 14 | /local 15 | i [integer!] 16 | ][ 17 | 18 | valid-multi-byte?: func [ 19 | b [byte!] 20 | return: [logic!] 21 | ][ 22 | not any [b < #"^(80)" b > #"^(BF)"] 23 | ] 24 | 25 | i: 1 26 | 27 | until [ 28 | if str/1 > #"^(7F)" [ ;; not ASCII ? 29 | 30 | ;; invalid characters 31 | if any [ 32 | #"^(C0)" = str/1 33 | #"^(C1)" = str/1 34 | #"^(F4)" < str/1 35 | ][ 36 | return i 37 | ] 38 | ;; two-byte characters 39 | either str/1 < #"^(E0)" [ 40 | unless valid-multi-byte? str/2 [return i] 41 | i: i + 1 42 | str: str + 1 43 | ][ 44 | ;; three-byte characters 45 | either str/1 < #"^(F0)" [ 46 | unless all [ 47 | valid-multi-byte? str/2 48 | valid-multi-byte? str/3 49 | ][ 50 | return i 51 | ] 52 | i: i + 2 53 | str: str + 2 54 | ][ 55 | ;; four-byte-characters 56 | unless all [ 57 | valid-multi-byte? str/2 58 | valid-multi-byte? str/3 59 | valid-multi-byte? str/4 60 | ][ 61 | return i 62 | ] 63 | i: i + 3 64 | str: str + 3 65 | ] 66 | ] 67 | ] 68 | i: i + 1 69 | str: str + 1 70 | str/1 = null-byte 71 | ] 72 | 0 73 | ] 74 | 75 | -------------------------------------------------------------------------------- /I64/Tests/mul-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - absolute mulide test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-mul.reds 10 | 11 | ~~~start-file~~~ "mul" 12 | 13 | --test-- "mul-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 2 16 | a/most-sig: 0 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 1 19 | b/most-sig: 0 20 | c: declare PWAW-I64-int64! 21 | r: PWAW-I64-mul a b c 22 | --assert PWAW-I64-OKAY = r 23 | --assert c/least-sig = 2 24 | --assert c/most-sig = 0 25 | 26 | --test-- "mul-2" 27 | a: declare PWAW-I64-int64! 28 | a/least-sig: FFFFFFFEh 29 | a/most-sig: FFFFFFFFh 30 | b: declare PWAW-I64-int64! 31 | b/least-sig: 2 32 | b/most-sig: 0 33 | c: declare PWAW-I64-int64! 34 | r: PWAW-I64-mul a b c 35 | --assert PWAW-I64-OKAY = r 36 | --assert c/least-sig = FFFFFFFCh 37 | --assert c/most-sig = FFFFFFFFh 38 | 39 | --test-- "mul-3" 40 | a: declare PWAW-I64-int64! 41 | a/least-sig: FFFFFFFEh 42 | a/most-sig: FFFFFFFFh 43 | b: declare PWAW-I64-int64! 44 | b/least-sig: FFFFFFFFh 45 | b/most-sig: FFFFFFFFh 46 | c: declare PWAW-I64-int64! 47 | r: PWAW-I64-mul a b c 48 | --assert PWAW-I64-OKAY = r 49 | --assert c/least-sig = 2 50 | --assert c/most-sig = 0 51 | 52 | --test-- "mul-4" 53 | a: declare PWAW-I64-int64! 54 | a/least-sig: 2 55 | a/most-sig: 0 56 | b: declare PWAW-I64-int64! 57 | b/least-sig: FFFFFFFEh 58 | b/most-sig: FFFFFFFFh 59 | c: declare PWAW-I64-int64! 60 | r: PWAW-I64-mul a b c 61 | --assert PWAW-I64-OKAY = r 62 | --assert c/least-sig = FFFFFFFCh 63 | --assert c/most-sig = FFFFFFFFh 64 | 65 | ~~~end-file~~~ 66 | 67 | -------------------------------------------------------------------------------- /UTF8/string-c-string.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "string to c-string" 3 | Author: "Peter W A Wood" 4 | File: %string-c-string.reds 5 | Version: 0.0.1 6 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 7 | License: "Distributed under the Boost Software License, Version 1.0." 8 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 9 | ] 10 | 11 | #include %ucs4-utf8.reds 12 | 13 | PWAW-string-c-string: func [ 14 | str [red-string!] 15 | return: [c-string!] 16 | /local 17 | b [byte!] 18 | s [series!] 19 | cp [integer!] 20 | p [byte-ptr!] 21 | p4 [int-ptr!] 22 | unit [integer!] 23 | utf8 [c-string!] 24 | utf8p [integer!] 25 | utf8ch [c-string!] 26 | utf8chp [integer!] 27 | ut8len [integer!] 28 | ][ 29 | #include %ucs4-utf8.reds 30 | 31 | p: as byte-ptr! 0 32 | p4: as int-ptr! 0 33 | b: as byte! 0 34 | p: string/rs-head str 35 | tail: string/rs-tail str 36 | utf8p: 1 37 | utf8ch: "" 38 | utf8chp: 1 39 | s: GET_BUFFER(str) 40 | unit: GET_UNIT(s) 41 | utf8len: 0 42 | while [p < tail][ ;; esitmate c-string length 43 | switch unit [ 44 | Latin1 [utf8len: utf8len + 1] 45 | UCS-2 [utf8len: utf8len + 3] 46 | UCS-4 [utf8len: utf8len + 4] 47 | ] 48 | p: p + unit 49 | ] 50 | utf8len: utf8len + 1 ;; allow for end of string 51 | utf8: as c-string! allocate utf8len 52 | p: string/rs-head str 53 | while [p < tail][ 54 | cp: switch unit [ 55 | Latin1 [as-integer p/value] 56 | UCS-2 [(as-integer p/2) << 8 + p/1] 57 | UCS-4 [p4: as int-ptr! p p4/value] 58 | ] 59 | utf8ch: PWAW-ucs4-utf8 cp 60 | utf8chp: 1 61 | until [ 62 | utf8/utf8p: utf8ch/utf8chp 63 | utf8p: utf8p + 1 64 | utf8chp: utf8chp + 1 65 | null-byte = utf8ch/utf8chp 66 | ] 67 | p: p + unit 68 | ] 69 | utf8/utf8p: null-byte ;; end the c-string 70 | 71 | utf8 72 | ] 73 | 74 | -------------------------------------------------------------------------------- /DateTime/Tests/duration-difference-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - duration-difference test script" 3 | Author: "Peter W A Wood" 4 | File: %date-difference-test.reds 5 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-DT-date-time.reds 11 | 12 | ~~~start-file~~~ "duration-difference" 13 | dd-dur1: declare PWAW-DT-duration! 14 | dd-dur2: declare PWAW-DT-duration! 15 | dd-dur: declare PWAW-DT-duration! 16 | init: does [ 17 | PWAW-DT-ZERO-DURATION(dd-dur1) 18 | PWAW-DT-ZERO-DURATION(dd-dur2) 19 | PWAW-DT-ZERO-DURATION(dd-dur) 20 | ] 21 | 22 | --test-- "dd-1" 23 | init 24 | --assert 0 = PWAW-DT-duration-difference dd-dur1 dd-dur2 dd-dur 25 | --assert 0 = dd-dur/days 26 | --assert 0 = dd-dur/hours 27 | --assert 0 = dd-dur/minutes 28 | --assert 0 = dd-dur/seconds 29 | --assert 0 = dd-dur/microseconds 30 | 31 | --test-- "dd-2" 32 | init 33 | dd-dur1/days: 1 34 | dd-dur2/hours: 1 35 | --assert 0 = PWAW-DT-duration-difference dd-dur1 dd-dur2 dd-dur 36 | --assert 0 = dd-dur/days 37 | --assert 23 = dd-dur/hours 38 | --assert 0 = dd-dur/minutes 39 | --assert 0 = dd-dur/seconds 40 | --assert 0 = dd-dur/microseconds 41 | 42 | --test-- "dd-3" 43 | init 44 | dd-dur1/days: 1 45 | dd-dur1/hours: 1 46 | dd-dur1/minutes: 1 47 | dd-dur1/seconds: 1 48 | dd-dur1/microseconds: 1 49 | dd-dur2/days: 0 50 | dd-dur2/hours: 2 51 | dd-dur2/minutes: 2 52 | dd-dur2/seconds: 2 53 | dd-dur2/microseconds: 2 54 | --assert 0 = PWAW-DT-duration-difference dd-dur1 dd-dur2 dd-dur 55 | --assert 0 = dd-dur/days 56 | --assert 22 = dd-dur/hours 57 | --assert 58 = dd-dur/minutes 58 | --assert 58 = dd-dur/seconds 59 | --assert 999 = dd-dur/microseconds 60 | 61 | ~~~end-file~~~ 62 | 63 | -------------------------------------------------------------------------------- /LibTom/LTM-div-2.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Divides an integer by 2" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-div-2: func [ 12 | "Divides an integer by 2" 13 | a [LTM-int!] "The integer to be halved" 14 | b [LTM-int!] "Half the integer" 15 | return: [integer!] "LTM-OKAY or an error code" 16 | /local 17 | i [integer!] ;; array index 18 | carry [LTM-digit!] ;; carry digit 19 | next-carry [LTM-digit!] ;; next carry digit to be applied 20 | oldused [integer!] ;; to store b/used as input 21 | response [integer!] ;; response code from library calls 22 | ][ 23 | 24 | ;; make sure there are sufficient digits to store the result 25 | if b/alloc < a/used [ 26 | response: LTM-grow b a/used 27 | if response <> LTM-OKAY [return response] 28 | ] 29 | 30 | ;; set used value of result 31 | oldused: b/used 32 | b/used: a/used 33 | 34 | ;; divide by two, one digit at time 35 | carry: LTM-ZERO-DIGIT 36 | i: b/used 37 | 38 | until [ 39 | 40 | ;;get what will be the next carry digit from 41 | ;; the most significant bit of the current digit 42 | next-carry: a/mp-digit/i and as LTM-digit! 1 43 | 44 | ;; now shift up this digit and add in previous carry 45 | b/mp-digit/i: (a/mp-digit/i >>> 1) or (carry << (LTM-DIGIT-BIT - 1)) 46 | 47 | ;;set the carry 48 | carry: next-carry 49 | 50 | i: i - 1 51 | i < 1 52 | ] 53 | 54 | ;; zero any excess digits that may not have been written over in the result 55 | if b/used < oldused [ 56 | LTM-zero-set (b/mp-digit (b/used + 1) oldused) 57 | ] 58 | 59 | ;; finally set the sign 60 | b/sign: a/sign 61 | 62 | LTM-clamp b ;; LTM-clamp retuns LTM-OKAY 63 | 64 | ] -------------------------------------------------------------------------------- /LibTom/LTM-sub.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "high level subtraction" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-sub: func [ 12 | "high level subtraction" 13 | a [LTM-int!] "The initial integer" 14 | b [LTM-int!] "The integer to be subtracted" 15 | c [LTM-int!] "The result of the subtraction" 16 | return: [integer!] "LTM-OKAY or an error code" 17 | /local 18 | response [integer!] ;; call responseponse code 19 | size-a [integer!] ;; size of first integer 20 | size-b [integer!] ;; size of second integer 21 | ][ 22 | 23 | ;; get sign of both inputs 24 | sign-a: a/sign 25 | sign-b: b/sign 26 | 27 | either sign-a <> sign-b [ 28 | ;; subtract a negative from a positive or +ve from a -ve 29 | ;; in either case, add their magnitudes and use sign from 1st number 30 | c/sign: sign-a 31 | response: LTM-s-add a b c 32 | ][ 33 | ;; subtract a positive from a positive or -ve from -ve 34 | ;; take the difference between their magnitudes 35 | ;; subtract the smaller from the larger 36 | ;; adjusting the sign as necessary 37 | either LTM-LT <> LTM-cmp-mag a b [ 38 | ;; first number is larger or they are equal in magnitude 39 | 40 | ;; take sign from first one and subtract second from first 41 | c/sign: sign-a 42 | response: LTM-s-sub a b c 43 | ][ 44 | ;; the second is of greater magnitude 45 | ;; the responseult will have the opposite sign to the first number 46 | either sign-a = LTM-ZPOS [ 47 | c/sign: LTM-NEG 48 | ][ 49 | c/sign: LTM-ZPOS 50 | ] 51 | response: LTM-s-sub b a c 52 | ] 53 | ] 54 | 55 | response 56 | 57 | ] 58 | -------------------------------------------------------------------------------- /I64/PWAW-I64-mul.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Multipleis two 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-abs-mul.reds 12 | #include %PWAW-I64-greater.reds 13 | #include %PWAW-I64-negate.reds 14 | 15 | PWAW-I64-mul: func [ 16 | a [PWAW-I64-int64!] 17 | b [PWAW-I64-int64!] 18 | c [PWAW-I64-int64!] 19 | return: [integer!] 20 | /local 21 | negate-ans? [logic!] 22 | resp [integer!] 23 | temp-a [PWAW-I64-int64!] 24 | temp-b [PWAW-I64-int64!] 25 | temp-c [PWAW-I64-int64!] 26 | ][ 27 | temp-a: declare PWAW-I64-int64! 28 | temp-b: declare PWAW-I64-int64! 29 | temp-c: declare PWAW-I64-int64! 30 | 31 | either PWAW-I64-positive?(a) [ 32 | either PWAW-I64-positive? (b) [ 33 | PWAW-I64-copy(a temp-a) 34 | PWAW-I64-copy(b temp-b) 35 | negate-ans?: false 36 | ][ 37 | ;a +ve, b-ve 38 | PWAW-I64-copy(a temp-a) 39 | resp: PWAW-I64-negate b temp-b 40 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 41 | negate-ans?: true 42 | ] 43 | ][ 44 | ; a -ve 45 | either PWAW-I64-negative? (b) [ 46 | resp: PWAW-I64-negate a temp-a 47 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 48 | resp: PWAW-I64-negate b temp-b 49 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 50 | negate-ans?: false 51 | ][ 52 | ; a-ve, b+ve 53 | resp: PWAW-I64-negate a temp-a 54 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 55 | PWAW-I64-copy(b temp-b) 56 | negate-ans?: true 57 | ] 58 | ] 59 | 60 | resp: PWAW-I64-abs-mul temp-a temp-b temp-c 61 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 62 | either negate-ans? [ 63 | resp: PWAW-I64-negate temp-c c 64 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 65 | ][ 66 | PWAW-I64-copy(temp-c c) 67 | ] 68 | PWAW-I64-OKAY 69 | ] 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /docs/template.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | $title 4 | 55 | 56 | 57 |
$content
58 |
59 | MakeDoc2 by REBOL - $date 60 |
61 | 62 | -------------------------------------------------------------------------------- /I64/PWAW-I64-div.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Adds two 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-abs-div.reds 12 | #include %PWAW-I64-greater.reds 13 | #include %PWAW-I64-negate.reds 14 | 15 | PWAW-I64-div: func [ 16 | a [PWAW-I64-int64!] 17 | b [PWAW-I64-int64!] 18 | c [PWAW-I64-int64!] 19 | return: [integer!] 20 | /local 21 | negate-ans? [logic!] 22 | resp [integer!] 23 | temp-a [PWAW-I64-int64!] 24 | temp-b [PWAW-I64-int64!] 25 | temp-c [PWAW-I64-int64!] 26 | temp-d [PWAW-I64-int64!] 27 | ][ 28 | temp-a: declare PWAW-I64-int64! 29 | temp-b: declare PWAW-I64-int64! 30 | temp-c: declare PWAW-I64-int64! 31 | temp-d: declare PWAW-I64-int64! 32 | 33 | either PWAW-I64-positive?(a) [ 34 | either PWAW-I64-positive? (b) [ 35 | PWAW-I64-copy(a temp-a) 36 | PWAW-I64-copy(b temp-b) 37 | negate-ans?: false 38 | ][ 39 | ;a +ve, b-ve 40 | PWAW-I64-copy(a temp-a) 41 | resp: PWAW-I64-negate b temp-b 42 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 43 | negate-ans?: true 44 | ] 45 | ][ 46 | ; a -ve 47 | either PWAW-I64-negative? (b) [ 48 | resp: PWAW-I64-negate a temp-a 49 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 50 | resp: PWAW-I64-negate b temp-b 51 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 52 | negate-ans?: false 53 | ][ 54 | ; a-ve, b+ve 55 | resp: PWAW-I64-negate a temp-a 56 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 57 | PWAW-I64-copy(b temp-b) 58 | negate-ans?: true 59 | ] 60 | ] 61 | 62 | resp: PWAW-I64-abs-div temp-a temp-b temp-c temp-d 63 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 64 | either negate-ans? [ 65 | resp: PWAW-I64-negate temp-c c 66 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 67 | ][ 68 | PWAW-I64-copy(temp-c c) 69 | ] 70 | PWAW-I64-copy(temp-d d) 71 | PWAW-I64-OKAY 72 | ] 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-duration-difference.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: { 3 | Subtracts a shorter duration from a longer one 4 | } 5 | Author: "Peter W A Wood" 6 | Version: 0.1.0 7 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 8 | License: "Distributed under the Boost Software License, Version 1.0." 9 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 10 | ] 11 | 12 | #include %../Core/PWAW-C-core.reds 13 | 14 | #include %PWAW-DT-duration-def.reds 15 | 16 | PWAW-DT-duration-difference: func [ 17 | {Subtracts a shorter duration from a longer one} 18 | d1 [PWAW-DT-duration!] {the longer duration} 19 | d2 [PWAW-DT-duration!] {the shorter duration} 20 | dur [PWAW-DT-duration!] {the difference} 21 | return: [integer!] 22 | { 23 | 0 - successful 24 | 1 - the first duration must be longer than the second 25 | } 26 | 27 | ][ 28 | PWAW-DT-ZERO-DURATION(dur) 29 | 30 | if any [ 31 | d2/days > d1/days 32 | all [ 33 | d2/days = d1/days 34 | d2/hours > d1/hours 35 | ] 36 | all [ 37 | d2/days = d1/days 38 | d2/hours = d1/hours 39 | d2/minutes > d1/minutes 40 | ] 41 | all [ 42 | d2/days = d1/days 43 | d2/hours = d1/hours 44 | d2/minutes = d1/minutes 45 | d2/seconds > d1/seconds 46 | ] 47 | all [ 48 | d2/days = d1/days 49 | d2/hours = d1/hours 50 | d2/minutes = d1/minutes 51 | d2/seconds = d1/seconds 52 | d2/microseconds > d1/microseconds 53 | ] 54 | ][ 55 | return 1 56 | ] 57 | 58 | dur/days: d1/days - d2/days 59 | dur/hours: d1/hours - d2/hours 60 | dur/minutes: d1/minutes - d2/minutes 61 | dur/seconds: d1/seconds - d2/seconds 62 | dur/microseconds: d1/microseconds - d2/microseconds 63 | if dur/microseconds < 0 [ 64 | dur/microseconds: dur/microseconds + 1000 65 | dur/seconds: dur/seconds - 1 66 | ] 67 | if dur/seconds < 0 [ 68 | dur/seconds: dur/seconds + 60 69 | dur/minutes: dur/minutes - 1 70 | ] 71 | if dur/minutes < 0 [ 72 | dur/minutes: dur/minutes + 60 73 | dur/hours: dur/hours - 1 74 | ] 75 | if dur/hours < 0 [ 76 | dur/hours: dur/hours + 24 77 | dur/days: dur/days - 1 78 | ] 79 | 80 | 0 81 | ] 82 | -------------------------------------------------------------------------------- /LibTom/LTM-mul-2.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Multiples an integer by 2" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-mul-2: func [ "Multiples an integer by 2" 12 | a [LTM-int!] "The integer to be doubled" 13 | b [LTM-int!] "Double the integer" 14 | return: [integer!] "LTM-OKAY or an error code" 15 | /local 16 | i [integer!] ;; array index 17 | carry [LTM-digit!] ;; carry digit 18 | next-carry [LTM-digit!] ;; next carry digit to be applied 19 | oldused [integer!] ;; to store b/used as input 20 | response [integer!] ;; response code from library calls 21 | ][ 22 | 23 | ;; make sure there are sufficient digits to store the response 24 | if b/alloc < (a/used + 1) [ 25 | response: LTM-grow b (a/used + 1) 26 | if response <> LTM-OKAY [return response] 27 | ] 28 | 29 | ;; set used value of response 30 | oldused: b/used 31 | b/used: a/used 32 | 33 | ;; multliply by two, one digit at time 34 | carry: LTM-ZERO-DIGIT 35 | i: 1 36 | 37 | until [ 38 | 39 | ;;get what will be the next carry digit from 40 | ;; the most significant bit of the current digit 41 | next-carry: a/mp-digit/i >>> (LTM-DIGIT-BIT - 1) 42 | 43 | ;; now shift up this digit and add in previous carry 44 | b/mp-digit/i: ((a/mp-digit/i << 1) or carry) and LTM-MASK 45 | 46 | ;;set the carry 47 | carry: next-carry 48 | 49 | i: i + 1 50 | i > a/used 51 | ] 52 | 53 | ;; add a new leading digit if there is a carry from the final shift 54 | ;; it will always be 1 55 | ;; note: i has already been incremented to be a/used + 1 56 | if carry <> LTM-ZERO-DIGIT [ 57 | b/mp-digit/i: as LTM-digit! 1 58 | b/used: b/used + 1 59 | ] 60 | 61 | ;; zero any excess digits that may not have been written over in the response 62 | if b/used < oldused [ 63 | LTM-zero-set (b/mp-digit (b/used + 1) oldused) 64 | ] 65 | 66 | ;; finally set the sign 67 | b/sign: a/sign 68 | 69 | LTM-OKAY 70 | 71 | ] -------------------------------------------------------------------------------- /I64/PWAW-I64-add.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Adds two 64-bit integers" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-abs-add.reds 12 | #include %PWAW-I64-abs-sub.reds 13 | #include %PWAW-I64-greater.reds 14 | #include %PWAW-I64-negate.reds 15 | 16 | PWAW-I64-add: func [ 17 | a [PWAW-I64-int64!] 18 | b [PWAW-I64-int64!] 19 | c [PWAW-I64-int64!] 20 | return: [integer!] 21 | /local 22 | resp [integer!] 23 | temp [PWAW-I64-int64!] 24 | temp2 [PWAW-I64-int64!] 25 | temp3 [PWAW-I64-int64!] 26 | ][ 27 | temp: declare PWAW-I64-int64! 28 | temp2: declare PWAW-I64-int64! 29 | temp3: declare PWAW-I64-int64! 30 | PWAW-I64-zero-int64(temp) 31 | PWAW-I64-zero-int64(temp2) 32 | PWAW-I64-zero-int64(temp3) 33 | 34 | either PWAW-I64-positive?(a) [ 35 | either PWAW-I64-positive? (b) [ 36 | return PWAW-I64-abs-add a b c 37 | ][ 38 | ;a +ve, b-ve 39 | resp: PWAW-I64-negate b temp 40 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 41 | either PWAW-I64-greater? a temp [ 42 | return PWAW-I64-abs-sub a temp c 43 | ][ 44 | resp: PWAW-I64-abs-sub temp a temp2 45 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 46 | return PWAW-I64-negate temp2 c 47 | ] 48 | ] 49 | ][ 50 | ; a -ve 51 | either PWAW-I64-negative? (b) [ 52 | resp: PWAW-I64-negate a temp 53 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 54 | resp: PWAW-I64-negate b temp2 55 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 56 | resp: PWAW-I64-abs-add temp temp2 temp3 57 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 58 | return PWAW-I64-negate temp3 c 59 | ][ 60 | ; a-ve, b+ve 61 | resp: PWAW-I64-negate a temp 62 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 63 | either PWAW-I64-greater? temp b [ 64 | resp: PWAW-I64-abs-sub temp b temp2 65 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 66 | return PWAW-I64-negate temp2 c 67 | ][ 68 | return PWAW-I64-abs-sub b temp c 69 | ] 70 | ] 71 | ] 72 | ] 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /UTF8/ucs4-utf8.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "ucs-4 to utf-8" 3 | Author: "Peter W A Wood" 4 | File: %ucs4-utf8.reds 5 | Version: 0.0.1 6 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 7 | License: "Distributed under the Boost Software License, Version 1.0." 8 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 9 | ] 10 | 11 | PWAW-ucs4-utf8: func [ 12 | ucs4 [integer!] 13 | return: [c-string!] 14 | /local 15 | byte [byte!] 16 | utf8 [struct! [ 17 | byte1 [byte!] 18 | byte2 [byte!] 19 | byte3 [byte!] 20 | byte4 [byte!] 21 | byte5 [byte!] 22 | ]] 23 | ][ 24 | 25 | utf8: declare struct! [ 26 | byte1 [byte!] 27 | byte2 [byte!] 28 | byte3 [byte!] 29 | byte4 [byte!] 30 | byte5 [byte!] 31 | ] 32 | 33 | utf8/byte1: null-byte 34 | utf8/byte2: null-byte 35 | utf8/byte3: null-byte 36 | utf8/byte4: null-byte 37 | utf8/byte5: null-byte 38 | 39 | either ucs4 < 128 [ 40 | utf8/byte1: as byte! ucs4 41 | ][ 42 | either ucs4 < 00010000h [ ;; BMP 43 | either ucs4 < 0800h [ 44 | byte: as byte! (ucs4 >>> 6) 45 | utf8/byte1: (as byte! C0h) or byte 46 | byte: as byte! (ucs4 and 3Fh) 47 | utf8/byte2: (as byte! 80h) or byte 48 | ][ 49 | byte: as byte! (ucs4 >>> 12) 50 | utf8/byte1: (as byte! E0h) or byte 51 | byte: as byte! ((ucs4 >>> 6) and 3Fh) 52 | utf8/byte2: (as byte! 80h) or byte 53 | byte: as byte! (ucs4 and 3Fh) 54 | utf8/byte3: (as byte! 80h) or byte 55 | ] 56 | ][ ;; only handles up to Code Point 57 | ;; 1FFFFFh which handles the 58 | ;; currently defined Unicode 59 | ;; planes (highest is 10FFFFh 60 | either ucs4 < 001FFFFFh [ 61 | byte: as byte! (ucs4 >>> 18) 62 | utf8/byte1: (as byte! F0h) or byte 63 | byte: as byte! ((ucs4 >>> 12) and 3Fh) 64 | utf8/byte2: (as byte! 80h) or byte 65 | byte: as byte! ((ucs4 >>> 6) and 3Fh) 66 | utf8/byte3: (as byte! 80h) or byte 67 | byte: as byte! (ucs4 and 3Fh) 68 | utf8/byte4: (as byte! 80h) or byte 69 | ][ 70 | utf8/byte1: null-byte ;; to signify error in input 71 | ] 72 | ] 73 | ] 74 | as c-string! utf8 75 | ] 76 | 77 | -------------------------------------------------------------------------------- /I64/PWAW-I64-sub.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Subtracts one 64-bit integer from another" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "https://github.com/Red/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %PWAW-I64-int64-def.reds 11 | #include %PWAW-I64-abs-add.reds 12 | #include %PWAW-I64-abs-sub.reds 13 | #include %PWAW-I64-greater.reds 14 | #include %PWAW-I64-negate.reds 15 | 16 | PWAW-I64-sub: func [ 17 | a [PWAW-I64-int64!] 18 | b [PWAW-I64-int64!] 19 | c [PWAW-I64-int64!] 20 | return: [integer!] 21 | /local 22 | resp [integer!] 23 | temp [PWAW-I64-int64!] 24 | temp2 [PWAW-I64-int64!] 25 | temp3 [PWAW-I64-int64!] 26 | ][ 27 | temp: declare PWAW-I64-int64! 28 | temp2: declare PWAW-I64-int64! 29 | temp3: declare PWAW-I64-int64! 30 | PWAW-I64-zero-int64(temp) 31 | PWAW-I64-zero-int64(temp2) 32 | PWAW-I64-zero-int64(temp3) 33 | 34 | either PWAW-I64-positive?(a) [ 35 | either PWAW-I64-positive? (b) [ 36 | either PWAW-I64-greater? a b [ 37 | return PWAW-I64-abs-sub a b c 38 | ][ 39 | resp: PWAW-I64-abs-sub b a temp 40 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 41 | return PWAW-I64-negate temp c 42 | ] 43 | ][ 44 | ;a +ve, b-ve 45 | resp: PWAW-I64-negate b temp 46 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 47 | return PWAW-I64-abs-add a temp c 48 | ] 49 | ][ 50 | ; a -ve 51 | either PWAW-I64-positive? (b) [ 52 | resp: PWAW-I64-negate a temp 53 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 54 | resp: PWAW-I64-abs-add temp b temp2 55 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 56 | return PWAW-I64-negate temp3 c 57 | ][ 58 | ; a-ve, b-ve 59 | resp: PWAW-I64-negate a temp 60 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 61 | resp: PWAW-I64-negate b temp2 62 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 63 | either PWAW-I64-greater? temp temp2 [ 64 | resp: PWAW-I64-abs-sub temp temp2 temp3 65 | ][ 66 | resp: PWAW-I64-abs-sub temp2 temp temp3 67 | ] 68 | PWAW-I64-return-if(resp <> PWAW-I64-OKAY) 69 | return PWAW-I64-negate temp3 c 70 | ] 71 | ] 72 | ] 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /I64/Tests/div-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - absolute divide test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-div.reds 10 | 11 | ~~~start-file~~~ "div" 12 | 13 | --test-- "div-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 2 16 | a/most-sig: 0 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 1 19 | b/most-sig: 0 20 | c: declare PWAW-I64-int64! 21 | d: declare PWAW-I64-int64! 22 | r: PWAW-I64-div a b c d 23 | --assert PWAW-I64-OKAY = r 24 | --assert c/least-sig = 2 25 | --assert c/most-sig = 0 26 | --assert d/least-sig = 0 27 | --assert d/most-sig = 0 28 | 29 | --test-- "div-2" 30 | a: declare PWAW-I64-int64! 31 | a/least-sig: FFFFFFFEh 32 | a/most-sig: FFFFFFFFh 33 | b: declare PWAW-I64-int64! 34 | b/least-sig: 2 35 | b/most-sig: 0 36 | c: declare PWAW-I64-int64! 37 | d: declare PWAW-I64-int64! 38 | r: PWAW-I64-div a b c d 39 | --assert PWAW-I64-OKAY = r 40 | --assert c/least-sig = FFFFFFFFh 41 | --assert c/most-sig = FFFFFFFFh 42 | --assert d/least-sig = 0 43 | --assert d/most-sig = 0 44 | 45 | --test-- "div-3" 46 | a: declare PWAW-I64-int64! 47 | a/least-sig: FFFFFFFEh 48 | a/most-sig: FFFFFFFFh 49 | b: declare PWAW-I64-int64! 50 | b/least-sig: FFFFFFFFh 51 | b/most-sig: FFFFFFFFh 52 | c: declare PWAW-I64-int64! 53 | d: declare PWAW-I64-int64! 54 | r: PWAW-I64-div a b c d 55 | --assert PWAW-I64-OKAY = r 56 | --assert c/least-sig = 2 57 | --assert c/most-sig = 0 58 | --assert d/least-sig = 0 59 | --assert d/most-sig = 0 60 | 61 | --test-- "div-2" 62 | a: declare PWAW-I64-int64! 63 | a/least-sig: 2 64 | a/most-sig: 0 65 | b: declare PWAW-I64-int64! 66 | b/least-sig: FFFFFFFEh 67 | b/most-sig: FFFFFFFFh 68 | c: declare PWAW-I64-int64! 69 | d: declare PWAW-I64-int64! 70 | r: PWAW-I64-div a b c d 71 | --assert PWAW-I64-OKAY = r 72 | --assert c/least-sig = FFFFFFFFh 73 | --assert c/most-sig = FFFFFFFFh 74 | --assert d/least-sig = 0 75 | --assert d/most-sig = 0 76 | 77 | ~~~end-file~~~ 78 | 79 | -------------------------------------------------------------------------------- /LibTom/libtommaths.def: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Multiple-precision integer library definitions" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | Description: "Definitions for LibTomMaths" 6 | File: %libtommaths.def 7 | License: {Distributed under the Boost Software License, Version 1.0. 8 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 9 | ] 10 | 11 | #define LTM-digit! byte! ;; needs to hold 12 | ;; DIGIT-BIT + 1 bits 13 | #define LTM-digit-ptr! [pointer! [byte!]] 14 | #define LTM-word! integer! ;; needs to hold 15 | ;; 2*DIGIT-BIT + 1 bits 16 | #define LTM-PREC 32 ;; default precision 17 | ;; (no. of digits) 18 | #define LTM-DIGIT-BIT 7 ;; bits in a digit 19 | 20 | #define LTM-ZERO-DIGIT #"^(00)" 21 | #define LTM-ONE-DIGIT #"^(01)" 22 | #define LTM-DIGIT-ZERO #"^(00)" 23 | #define LTM-DIGIT-ONE #"^(01)" 24 | 25 | #define LTM-LT -1 ;; less than 26 | #define LTM-EQ 0 ;; equal 27 | #define LTM-GT 1 ;; greater than 28 | 29 | #define LTM-OKAY 0 ;; no error occurred 30 | #define LTM-MEM 1 ;; out of memory 31 | #define LTM-INVALID 2 ;; invalid mp-integer 32 | #define LTM-INVALID-ARGS 3 ;; invalid function arguments 33 | ;; were supplied 34 | #define LTM-TOO-BIG 4 ;; supplied number was too big 35 | 36 | #define LTM-YES true 37 | #define LTM-NO false 38 | 39 | #define LTM-ZPOS 0 ;; positive integer 40 | #define LTM-NEG 1 ;; negative integer 41 | 42 | LTM-MASK: (((as LTM-digit! 1) << as LTM-digit! LTM-DIGIT-BIT) - 43 | (as LTM-digit! 1)) 44 | 45 | #define LTM-pad-size(size) [ 46 | size: size + (LTM-PREC * 2) - (size % LTM-PREC) 47 | ] 48 | 49 | LTM-digit-index: 0 50 | #define LTM-zero-set(digit start end) [ 51 | LTM-digit-index: end 52 | until [ 53 | digit/LTM-digit-index: LTM-ZERO-DIGIT 54 | LTM-digit-index: LTM-digit-index - 1 55 | LTM-digit-index < start 56 | ] 57 | ] 58 | 59 | #define LTM-zero?(a) [ 60 | either a/used = 0 [LTM-YES] [LTM-NO] 61 | ] 62 | 63 | LTM-int!: alias struct! [ 64 | used [integer!] 65 | alloc [integer!] 66 | sign [integer!] 67 | mp-digit [LTM-digit-ptr!] 68 | ] 69 | 70 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-UTC.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Converts a date to UTC time" 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | 11 | #include %PWAW-DT-date-def.reds 12 | #include %PWAW-DT-date-to-days.reds 13 | #include %PWAW-DT-days-to-date.reds 14 | 15 | PWAW-DT-UTC: func [ 16 | { 17 | Converts a date to UTC time 18 | } 19 | d [PWAW-DT-Date!] {a date to be converted} 20 | u [PWAW-DT-Date!] {the date at UTC time} 21 | return: [integer!] {returns: 22 | 23 | 0 - Success 24 | 1 - Cannot convert date to days 25 | 2 - Cannot convert days to date 26 | 27 | } 28 | /local 29 | days [integer!] 30 | tempdate [PWAW-DT-Date!] 31 | carry-hour [integer!] 32 | ][ 33 | tempdate: declare PWAW-DT-Date! 34 | PWAW-DT-ZERO-DATE(tempdate) 35 | days: 0 36 | carry-hour: 0 37 | u/year: d/year 38 | u/month: d/month 39 | u/day: d/day 40 | u/seconds: d/seconds 41 | u/microseconds: d/microseconds 42 | u/tz-hours: 0 43 | u/tz-minutes: 0 44 | 45 | either d/tz-hours >= 0 [ 46 | u/minutes: d/minutes - d/tz-minutes 47 | if u/minutes < 0 [ 48 | carry-hour: 1 49 | u/minutes: u/minutes + 60 50 | ] 51 | u/hour: d/hour - d/tz-hours - carry-hour 52 | if u/hour < 0 [ 53 | u/hour: u/hour + 24 54 | ;; need to check round trip date-to-days and back!!! 55 | if 0 <> PWAW-DT-date-to-days u :days [return 1] 56 | 57 | days: days - 1 58 | 59 | if 0 <> PWAW-DT-days-to-date days tempdate [return 2] 60 | u/year: tempdate/year 61 | u/month: tempdate/month 62 | u/day: tempdate/day 63 | ] 64 | ][ 65 | u/minutes: d/minutes + d/tz-minutes 66 | if u/minutes > 60 [ 67 | u/minutes: u/minutes - 60 68 | carry-hour: 1 69 | ] 70 | u/hour: d/hour - d/tz-hours + carry-hour ;; tz-hours is negative 71 | if u/hour > 24 [ 72 | u/hour: u/hour - 24 73 | if 0 <> PWAW-DT-date-to-days u :days [return 1] 74 | days: days + 1 75 | if 0 <> PWAW-DT-days-to-date days tempdate [return 2] 76 | u/year: tempdate/year 77 | u/month: tempdate/month 78 | u/day: tempdate/month 79 | ] 80 | ] 81 | 82 | 0 83 | ] 84 | 85 | -------------------------------------------------------------------------------- /I64/Tests/negate-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - negate test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-negate.reds 10 | 11 | ~~~start-file~~~ "negate" 12 | 13 | --test-- "negate-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 1 16 | a/most-sig: 0 17 | b: declare PWAW-I64-int64! 18 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 19 | --assert b/least-sig = FFFFFFFFh 20 | --assert b/most-sig = FFFFFFFFh 21 | 22 | --test-- "negate-2" 23 | a: declare PWAW-I64-int64! 24 | a/least-sig: 1 25 | a/most-sig: 80000000h 26 | b: declare PWAW-I64-int64! 27 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 28 | --assert b/least-sig = FFFFFFFFh 29 | --assert b/most-sig = 7FFFFFFFh 30 | 31 | --test-- "negate-3" 32 | a: declare PWAW-I64-int64! 33 | a/least-sig: 445566 34 | a/most-sig: 111222333 35 | b: declare PWAW-I64-int64! 36 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 37 | --assert b/least-sig = FFF93382h 38 | --assert b/most-sig = F95EE1C2h 39 | 40 | --test-- "negate-4" 41 | a: declare PWAW-I64-int64! 42 | a/least-sig: 445566 43 | a/most-sig: -111222333 44 | b: declare PWAW-I64-int64! 45 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 46 | --assert b/least-sig = FFF93382h 47 | --assert b/most-sig = 06A11E3Ch 48 | 49 | --test-- "negate-5" 50 | a: declare PWAW-I64-int64! 51 | a/least-sig: FFFFFFFFh 52 | a/most-sig: 7FFFFFFFh 53 | b: declare PWAW-I64-int64! 54 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 55 | --assert b/least-sig = 1 56 | --assert b/most-sig = 80000000h 57 | 58 | --test-- "negate-6" 59 | a: declare PWAW-I64-int64! 60 | a/least-sig: 2 61 | a/most-sig: 80000000h 62 | b: declare PWAW-I64-int64! 63 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 64 | --assert b/least-sig = -2 65 | --assert b/most-sig = 7FFFFFFFh 66 | 67 | --test-- "negate-7" 68 | a: declare PWAW-I64-int64! 69 | a/least-sig: 0 70 | a/most-sig: 0 71 | b: declare PWAW-I64-int64! 72 | --assert PWAW-I64-OKAY = PWAW-I64-negate a b 73 | --assert b/least-sig = 0 74 | --assert b/most-sig = 0 75 | 76 | ~~~end-file~~~ 77 | 78 | -------------------------------------------------------------------------------- /LibTom/LTM-div-2d.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Divides an integer by a power of 2" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | #include %LTM-clear.reds 11 | #include %LTM-copy.reds 12 | #include %LTM-mod-2d.reds 13 | #include %LTM-rshd.reds 14 | #include %LTM-zero.reds 15 | 16 | LTM-div-2d: func [ 17 | { 18 | shift right by a certain bit count: 19 | (storing quotient in c, remainder in d) 20 | } 21 | a [LTM-int!] "The integer to be dvided" 22 | b [integer!] "Shift count" 23 | c [LTM-int!] "Quotient" 24 | d [LTM-int!] "Remainder" 25 | return: [integer!] "LTM-OKAY or an error code" 26 | /local 27 | i [integer!] ;; array index 28 | carry [LTM-digit!] ;; carry digit 29 | mask [LTM-digit!] 30 | next-carry [LTM-digit!] ;; next carry digit to be applied 31 | num-bits [integer!] ;; number of bits 32 | res [integer!] ;; response code from library calls 33 | shift [integer!] 34 | ][ 35 | ;; initialisation 36 | carry: LTM-DIGIT-ZERO 37 | mask: LTM-DIGIT-ZERO 38 | next-carry: LTM-DIGIT-ZERO 39 | shift: 0 40 | 41 | ;; copy input to result for processing without affecting input 42 | res: LTM-copy a c 43 | if res <> LTM-OKAY [return res] 44 | 45 | ;; if the shift count is 0 or less, return original value, 0 remainder 46 | if b < 1 [ 47 | res: LTM-zero d 48 | if res <> 0 [return res] 49 | ] 50 | 51 | ;; get the remainder 52 | res: LTM-mod-2d a b d 53 | if res <> LTM-OKAY [ 54 | LTM-clear d 55 | return res 56 | ] 57 | 58 | ;; shift by as many digits in the bit count 59 | if b >= LTM-DIGIT-BIT [ 60 | LTM-rshd c (b / LTM-DIGIT-BIT) 61 | ] 62 | 63 | ;; shift any bit count < digit bit 64 | num-bits: b % LTM-DIGIT-BIT 65 | if num-bits > 0 [ 66 | mask:(LTM-DIGIT-ONE << num-bits) - 1 67 | shift: LTM-DIGIT-BIT - num-bits ;; for lsb 68 | i: c/used 69 | until [ 70 | 71 | ;; put the lower bits of this word into next-carry 72 | next-carry: c/mp-digit/i and mask 73 | 74 | ;; shift current word and mix in any carry bits from previous word 75 | c/mp-digit/i: (c/mp-digit/i >> num-bits) or (carry << shift) 76 | 77 | carry: next-carry 78 | i: i - 1 79 | i < 1 80 | ] 81 | ] 82 | 83 | res: LTM-clamp c 84 | 85 | return res 86 | ] -------------------------------------------------------------------------------- /LibTom/Tests/mp-mod-2d-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-mod-2d" 4 | 5 | --test-- "mpmod2d1" 6 | mpmod2d1-mp-int1: declare LTM-int! 7 | response: LTM-init mpmod2d1-mp-int1 8 | --assert response = LTM-OKAY 9 | response: LTM-set-int mpmod2d1-mp-int1 2 10 | --assert response = LTM-OKAY 11 | mpmod2d1-mp-int2: declare LTM-int! 12 | response: LTM-init mpmod2d1-mp-int2 13 | --assert response = LTM-OKAY 14 | response: LTM-mod-2d mpmod2d1-mp-int1 0 mpmod2d1-mp-int2 15 | --assert response = LTM-OKAY 16 | --assert mpmod2d1-mp-int2/mp-digit/1 = (as LTM-digit! 0) 17 | --assert mpmod2d1-mp-int2/used = 0 18 | --assert mpmod2d1-mp-int2/sign = LTM-ZPOS 19 | 20 | --test-- "mpmod2d2" 21 | mpmod2d2-mp-int1: declare LTM-int! 22 | response: LTM-init mpmod2d2-mp-int1 23 | --assert response = LTM-OKAY 24 | response: LTM-set-int mpmod2d2-mp-int1 3 25 | --assert response = LTM-OKAY 26 | mpmod2d2-mp-int2: declare LTM-int! 27 | response: LTM-init mpmod2d2-mp-int2 28 | --assert response = LTM-OKAY 29 | response: LTM-mod-2d mpmod2d2-mp-int1 2 mpmod2d2-mp-int2 30 | --assert response = LTM-OKAY 31 | --assert mpmod2d2-mp-int2/mp-digit/1 = (as LTM-digit! 3) 32 | --assert mpmod2d2-mp-int2/used = 1 33 | --assert mpmod2d2-mp-int2/sign = LTM-ZPOS 34 | 35 | --test-- "mpmod2d3" 36 | mpmod2d3-mp-int1: declare LTM-int! 37 | response: LTM-init mpmod2d3-mp-int1 38 | --assert response = LTM-OKAY 39 | response: LTM-set-int mpmod2d3-mp-int1 3 40 | --assert response = LTM-OKAY 41 | mpmod2d3-mp-int2: declare LTM-int! 42 | response: LTM-init mpmod2d3-mp-int2 43 | --assert response = LTM-OKAY 44 | response: LTM-mod-2d mpmod2d3-mp-int1 1 mpmod2d3-mp-int2 45 | --assert response = LTM-OKAY 46 | --assert mpmod2d3-mp-int2/mp-digit/1 = (as LTM-digit! 1) 47 | --assert mpmod2d3-mp-int2/used = 1 48 | --assert mpmod2d3-mp-int2/sign = LTM-ZPOS 49 | 50 | --test-- "mpmod2d4" 51 | mpmod2d4-mp-int1: declare LTM-int! 52 | response: LTM-init mpmod2d4-mp-int1 53 | --assert response = LTM-OKAY 54 | response: LTM-set-int mpmod2d4-mp-int1 3 55 | --assert response = LTM-OKAY 56 | mpmod2d4-mp-int2: declare LTM-int! 57 | response: LTM-init mpmod2d4-mp-int2 58 | --assert response = LTM-OKAY 59 | response: LTM-mod-2d mpmod2d4-mp-int1 128 mpmod2d4-mp-int2 60 | --assert response = LTM-OKAY 61 | --assert mpmod2d4-mp-int2/mp-digit/1 = (as LTM-digit! 3) 62 | --assert mpmod2d4-mp-int2/used = 1 63 | --assert mpmod2d4-mp-int2/sign = LTM-ZPOS 64 | 65 | ===end-group=== -------------------------------------------------------------------------------- /Core/PWAW-C-str-int.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: {Checks that a string contains a literal representation of an 3 | integer."} 4 | Author: "Peter W A Wood" 5 | Version: 0.2.0 6 | Rights: "Copyright © 2012-2103 Peter W A Wood. All rights reserved." 7 | License: "Distributed under the Boost Software License, Version 1.0." 8 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 9 | ] 10 | 11 | PWAW-C-str-int?: func [ 12 | ;; checks a string is a correct literal representation of an integer 13 | ;; this is initial versions only handles decimal literal 14 | ;; returns logic! : 15 | ;; true - string contains an integer 16 | ;; false - string does not contain an integer 17 | ;; the function expects a c-string as the first argument 18 | s [c-string!] 19 | return: [logic!] 20 | /local 21 | end [integer!] 22 | len [integer!] 23 | neg? [logic!] 24 | pos [integer!] 25 | sign? [logic!] 26 | start [integer!] 27 | ][ 28 | neg?: false 29 | sign?: false 30 | len: length? s 31 | 32 | start: 1 33 | end: len 34 | len: end - start + 1 35 | pos: start 36 | 37 | either any [ 38 | s/1 = #"-" 39 | s/1 = #"+" 40 | ][ 41 | sign?: true 42 | if any [ 43 | len = 1 44 | len > 11 45 | ][ 46 | return false 47 | ] 48 | if s/1 = #"-" [neg?: true] 49 | s: s + 1 50 | ][ 51 | if len > 10 [return false] 52 | ] 53 | until [ 54 | if any [ 55 | s/1 < #"0" 56 | s/1 > #"9" 57 | ][return false] 58 | s: s + 1 59 | s/1 = null-byte 60 | ] 61 | ;; now check for max-size 62 | s: s - len ;; go back to start of string 63 | if sign? [ 64 | s: s + 1 65 | len: len - 1 66 | ] 67 | if len = 10 [ 68 | if s/1 > #"2" [return false] 69 | if s/1 < #"2" [return true] 70 | if s/2 > #"1" [return false] 71 | if s/2 < #"1" [return true] 72 | if s/3 > #"4" [return false] 73 | if s/3 < #"4" [return true] 74 | if s/4 > #"7" [return false] 75 | if s/4 < #"7" [return true] 76 | if s/5 > #"4" [return false] 77 | if s/5 < #"4" [return true] 78 | if s/6 > #"8" [return false] 79 | if s/6 < #"8" [return true] 80 | if s/7 > #"3" [return false] 81 | if s/7 < #"3" [return true] 82 | if s/8 > #"6" [return false] 83 | if s/8 < #"6" [return true] 84 | if s/9 > #"4" [return false] 85 | if s/9 < #"4" [return true] 86 | either neg? [ 87 | if s/10 > #"8" [return false] 88 | ][ 89 | if s/10 > #"7" [return false] 90 | ] 91 | ] 92 | true 93 | ] 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-date-difference.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: { 3 | Calculates the difference between two dates in days, hours, minutes, 4 | seconds and milliseconds 5 | } 6 | Author: "Peter W A Wood" 7 | Version: 0.1.0 8 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 9 | License: "Distributed under the Boost Software License, Version 1.0." 10 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 11 | ] 12 | 13 | #include %../Core/PWAW-C-core.reds 14 | 15 | #include %PWAW-DT-date-def.reds 16 | #include %PWAW-DT-duration-def.reds 17 | #include %PWAW-DT-date-to-days.reds 18 | #include %PWAW-DT-days-in-year-todate.reds 19 | #include %PWAW-DT-duration-difference.reds 20 | #include %PWAW-DT-equal.reds 21 | #include %PWAW-DT-later.reds 22 | 23 | PWAW-DT-date-difference: func [ 24 | {Calculates the between two dates} 25 | d1 [PWAW-DT-date!] {the first date} 26 | d2 [PWAW-DT-date!] {second date} 27 | dur [PWAW-DT-duration!] {for the calculated duration} 28 | return: [integer!] 29 | { 30 | 0 - successful 31 | 1 - error converting to UTC 32 | 2 - error converting date to days 33 | 3 - error getting days to-date in current year 34 | 4 - error calculating difference in durations since 0/1/1 35 | } 36 | /local 37 | dur1 [PWAW-DT-duration!] 38 | dur2 [PWAW-DT-duration!] 39 | i [integer!] 40 | utc-d1 [PWAW-DT-date!] 41 | utc-d2 [PWAW-DT-date!] 42 | 43 | 44 | ][ 45 | PWAW-DT-ZERO-DURATION(dur) 46 | dur1: declare PWAW-DT-duration! 47 | PWAW-DT-ZERO-DURATION(dur1) 48 | dur2: declare PWAW-DT-duration! 49 | PWAW-DT-ZERO-DURATION(dur2) 50 | utc-d1: declare PWAW-DT-date! 51 | utc-d2: declare PWAW-DT-date! 52 | i: 0 53 | 54 | if PWAW-DT-equal? d1 d2 [ 55 | PWAW-DT-ZERO-DURATION(dur) 56 | return 0 57 | ] 58 | 59 | either PWAW-DT-later? d1 d2 [ 60 | if 0 <> PWAW-DT-UTC d1 utc-d1 [return 1] 61 | if 0 <> PWAW-DT-UTC d2 utc-d2 [return 1] 62 | ][ 63 | if 0 <> PWAW-DT-UTC d2 utc-d1 [return 1] 64 | if 0 <> PWAW-DT-UTC d1 utc-d2 [return 1] 65 | ] 66 | 67 | if 0 <> PWAW-DT-date-to-days utc-d1 :i [return 2] 68 | dur1/days: i 69 | dur1/hours: utc-d1/hour 70 | dur1/minutes: utc-d1/minutes 71 | dur1/seconds: utc-d1/seconds 72 | dur1/microseconds: utc-d1/microseconds 73 | if 0 <> PWAW-DT-date-to-days utc-d2 :i [return 2] 74 | dur2/days: i 75 | dur2/hours: utc-d2/hour 76 | dur2/minutes: utc-d2/minutes 77 | dur2/seconds: utc-d2/seconds 78 | dur2/microseconds: utc-d2/microseconds 79 | 80 | if 0 <> PWAW-DT-duration-difference dur1 dur2 dur [ 81 | PWAW-DT-ZERO-DURATION(dur) 82 | return 4 83 | ] 84 | 85 | 0 86 | ] 87 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-lshb-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "left shift bits - multiply by power of 2" 4 | 5 | --test-- "mp-lshb1" 6 | mp-lshb1-int: declare LTM-int! 7 | response: LTM-init mp-lshb1-int 8 | --assert response = LTM-OKAY 9 | mp-lshb1-int/used: 4 10 | mp-lshb1-int/mp-digit/1: as LTM-digit! 4 11 | mp-lshb1-int/mp-digit/2: as LTM-digit! 8 12 | mp-lshb1-int/mp-digit/3: as LTM-digit! 16 13 | mp-lshb1-int/mp-digit/4: as LTM-digit! 2 14 | mp-lshb1-int2: declare LTM-int! 15 | response: LTM-mul-2d mp-lshb1-int 3 mp-lshb1-int2 16 | --assert response = LTM-OKAY 17 | --assert mp-lshb1-int2/used = 4 18 | --assert mp-lshb1-int2/mp-digit/1 = as LTM-digit! 32 19 | --assert mp-lshb1-int2/mp-digit/2 = as LTM-digit! 64 20 | --assert mp-lshb1-int2/mp-digit/3 = as LTM-digit! 0 21 | --assert mp-lshb1-int2/mp-digit/4 = as LTM-digit! 17 22 | 23 | --test-- "mp-lshb2" 24 | mp-lshb2-int: declare LTM-int! 25 | response: LTM-init mp-lshb2-int 26 | --assert response = LTM-OKAY 27 | mp-lshb2-int/used: 0 28 | mp-lshb2-int2: declare LTM-int! 29 | response: LTM-mul-2d mp-lshb2-int 3 mp-lshb2-int2 30 | --assert response = LTM-OKAY 31 | --assert mp-lshb2-int2/used = 0 32 | 33 | --test-- "mp-lshb3" 34 | mp-lshb3-int: declare LTM-int! 35 | response: LTM-init mp-lshb3-int 36 | --assert response = LTM-OKAY 37 | mp-lshb3-int/used: 4 38 | mp-lshb3-int/mp-digit/1: as LTM-digit! 4 39 | mp-lshb3-int/mp-digit/2: as LTM-digit! 8 40 | mp-lshb3-int/mp-digit/3: as LTM-digit! 16 41 | mp-lshb3-int/mp-digit/4: as LTM-digit! 2 42 | response: LTM-mul-2d mp-lshb3-int 3 mp-lshb3-int 43 | --assert response = LTM-OKAY 44 | --assert mp-lshb3-int/used = 4 45 | --assert mp-lshb3-int/mp-digit/1 = as LTM-digit! 32 46 | --assert mp-lshb3-int/mp-digit/2 = as LTM-digit! 64 47 | --assert mp-lshb3-int/mp-digit/3 = as LTM-digit! 0 48 | --assert mp-lshb3-int/mp-digit/4 = as LTM-digit! 17 49 | 50 | --test-- "mp-lshb4" 51 | mp-lshb4-int: declare LTM-int! 52 | response: LTM-init mp-lshb4-int 53 | --assert response = LTM-OKAY 54 | mp-lshb4-int/used: 4 55 | mp-lshb4-int/mp-digit/1: as LTM-digit! 4 56 | mp-lshb4-int/mp-digit/2: as LTM-digit! 8 57 | mp-lshb4-int/mp-digit/3: as LTM-digit! 16 58 | mp-lshb4-int/mp-digit/4: as LTM-digit! 127 59 | response: LTM-mul-2d mp-lshb4-int 3 mp-lshb4-int 60 | --assert response = LTM-OKAY 61 | --assert mp-lshb4-int/used = 5 62 | --assert mp-lshb4-int/mp-digit/1 = as LTM-digit! 32 63 | --assert mp-lshb4-int/mp-digit/2 = as LTM-digit! 64 64 | --assert mp-lshb4-int/mp-digit/3 = as LTM-digit! 0 65 | --assert mp-lshb4-int/mp-digit/4 = as LTM-digit! 121 66 | --assert mp-lshb4-int/mp-digit/5 = as LTM-digit! 7 67 | 68 | ===end-group=== 69 | -------------------------------------------------------------------------------- /DateTime/Tests/later-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - later? test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2012-2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "later?" 12 | 13 | dd-date1: declare PWAW-DT-date! 14 | dd-date2: declare PWAW-DT-date! 15 | 16 | --test-- "l-1" 17 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 18 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 19 | --assert not PWAW-DT-later? dd-date1 dd-date2 20 | 21 | --test-- "l-2" 22 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 23 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:15" dd-date2 24 | --assert not PWAW-DT-later? dd-date1 dd-date2 25 | 26 | --test-- "l-3" 27 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 28 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+09:30" dd-date2 29 | --assert PWAW-DT-later? dd-date1 dd-date2 30 | 31 | --test-- "l-4" 32 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 33 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:26+08:30" dd-date2 34 | --assert PWAW-DT-later? dd-date1 dd-date2 35 | 36 | --test-- "l-5" 37 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 38 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 39 | dd-date1/microseconds: 356 40 | dd-date2/microseconds: 355 41 | --assert PWAW-DT-later? dd-date1 dd-date2 42 | 43 | --test-- "l-6" 44 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:45:27+08:30" dd-date1 45 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 46 | --assert not PWAW-DT-later? dd-date1 dd-date2 47 | 48 | --test-- "l-7" 49 | dd-r: PWAW-DT-load-date "13-Jan-2012/15:46:27+08:30" dd-date1 50 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 51 | --assert not PWAW-DT-later? dd-date1 dd-date2 52 | 53 | --test-- "l-8" 54 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 55 | dd-r: PWAW-DT-load-date "12-Jan-2012/16:46:27+08:30" dd-date2 56 | --assert PWAW-DT-later? dd-date1 dd-date2 57 | 58 | --test-- "l-9" 59 | dd-r: PWAW-DT-load-date "13-Feb-2012/16:46:27+08:30" dd-date1 60 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 61 | --assert PWAW-DT-later? dd-date1 dd-date2 62 | 63 | --test-- "l-10" 64 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 65 | dd-r: PWAW-DT-load-date "13-Jan-2013/16:46:27+08:30" dd-date2 66 | --assert not PWAW-DT-later? dd-date1 dd-date2 67 | 68 | ~~~end-file~~~ 69 | 70 | -------------------------------------------------------------------------------- /DateTime/Tests/equal-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - equal test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2012-2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "equal" 12 | 13 | dd-date1: declare PWAW-DT-date! 14 | dd-date2: declare PWAW-DT-date! 15 | 16 | --test-- "de-1" 17 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 18 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 19 | --assert PWAW-DT-equal? dd-date1 dd-date2 20 | 21 | --test-- "de-2" 22 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 23 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:15" dd-date2 24 | --assert not PWAW-DT-equal? dd-date1 dd-date2 25 | 26 | --test-- "de-3" 27 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 28 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+09:30" dd-date2 29 | --assert not PWAW-DT-equal? dd-date1 dd-date2 30 | 31 | --test-- "de-4" 32 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 33 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:26+08:30" dd-date2 34 | --assert not PWAW-DT-equal? dd-date1 dd-date2 35 | 36 | --test-- "de-5" 37 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 38 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 39 | dd-date1/microseconds: 356 40 | dd-date2/microseconds: 355 41 | --assert not PWAW-DT-equal? dd-date1 dd-date2 42 | 43 | --test-- "de-6" 44 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 45 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:45:27+08:30" dd-date2 46 | --assert not PWAW-DT-equal? dd-date1 dd-date2 47 | 48 | --test-- "de-7" 49 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 50 | dd-r: PWAW-DT-load-date "13-Jan-2012/15:46:27+08:30" dd-date2 51 | --assert not PWAW-DT-equal? dd-date1 dd-date2 52 | 53 | --test-- "de-8" 54 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 55 | dd-r: PWAW-DT-load-date "12-Jan-2012/16:46:27+08:30" dd-date2 56 | --assert not PWAW-DT-equal? dd-date1 dd-date2 57 | 58 | --test-- "de-9" 59 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 60 | dd-r: PWAW-DT-load-date "13-Feb-2012/16:46:27+08:30" dd-date2 61 | --assert not PWAW-DT-equal? dd-date1 dd-date2 62 | 63 | --test-- "de-10" 64 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 65 | dd-r: PWAW-DT-load-date "13-Jan-2013/16:46:27+08:30" dd-date2 66 | --assert not PWAW-DT-equal? dd-date1 dd-date2 67 | 68 | ~~~end-file~~~ 69 | 70 | -------------------------------------------------------------------------------- /LibTom/LTM-s-sub.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "low level subtraction - absolute values - first number must be larger of two" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-s-sub: func [ 12 | "low level subtraction - absolute values - first number must be larger of two" 13 | a [LTM-int!] "The larger integer" 14 | b [LTM-int!] "The integer to be subtracted" 15 | c [LTM-int!] "The result" 16 | return: [integer!] "LTM-OKAY or an error code" 17 | /local 18 | carry [LTM-digit!] ;; carry digit 19 | i [integer!] ;; counter 20 | min [integer!] ;; min number of digits 21 | max [integer!] ;; max number of digits 22 | oldused [integer!] ;; value of c/used at start 23 | response [integer!] ;; call response code 24 | ][ 25 | 26 | ;; find sizes 27 | min: b/used 28 | max: a/used 29 | 30 | ;; extend the responseult if needed 31 | if c/alloc < max [ 32 | response: LTM-grow c max 33 | if response <> LTM-OKAY [return response] 34 | ] 35 | 36 | ;; get old used digit count and set new one 37 | oldused: c/used 38 | c/used: max 39 | 40 | ;; zero the carry 41 | carry: as LTM-digit! 0 42 | 43 | ;; perform the subtraction 44 | 45 | ;;subtract the digits which both numbers have 46 | ;; compute answers one digit at a time 47 | i: 1 48 | until[ 49 | ;; C[i] = A[i] - B[i] - Carry 50 | c/mp-digit/i: a/mp-digit/i - b/mp-digit/i - carry 51 | 52 | ;; carry = carry bit of C[i] 53 | carry: c/mp-digit/i >>> LTM-DIGIT-BIT 54 | 55 | ;; take away carry bit from Sum[i] 56 | c/mp-digit/i: c/mp-digit/i and LTM-MASK 57 | 58 | ;; increment counter and pointers 59 | i: i + 1 60 | 61 | i > min 62 | ] 63 | 64 | ;; now copy the "higher" digits, remembering to carry where needed 65 | 66 | if max > min [ 67 | i: min + 1 68 | until [ 69 | ;; copy each digit but remembering the carry 70 | c/mp-digit/i: a/mp-digit/i - carry 71 | 72 | ;; get carry for next digit 73 | carry: c/mp-digit/i >>> LTM-DIGIT-BIT 74 | 75 | ;; take away carry from C[i] 76 | c/mp-digit/i: c/mp-digit/i and LTM-MASK 77 | 78 | i: i + 1 79 | 80 | i > max 81 | ] 82 | ] 83 | 84 | ;; clear any digits in result that may have been left over 85 | if oldused > max [ LTM-zero-set(c/mp-digit (max + 1) oldused)] 86 | 87 | ;; remove any leading zeros 88 | ;; clamp will return okay or an error 89 | LTM-clamp c 90 | 91 | ] -------------------------------------------------------------------------------- /DateTime/PWAW-DT-days-to-date.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "A days to date conversion function " 3 | Author: "Peter W A Wood" 4 | Version: 0.1.0 5 | Rights: "Copyright © 2013 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | 11 | #include %PWAW-DT-date-def.reds 12 | #include %PWAW-DT-leapyear.reds 13 | 14 | PWAW-DT-days-to-date: func [ 15 | { 16 | Converts a number of days since 31/12/1 BC (i.e.1 = 1/1/1) to a date) 17 | } 18 | days [integer!] {number of days} 19 | d [PWAW-DT-Date!] {a date to be converted} 20 | return: [integer!] {returns: 21 | 22 | 0 - Success 23 | 1 - internal error in days-to-date 24 | } 25 | /local 26 | rem [integer!] 27 | year [integer!] 28 | 29 | ][ 30 | year: (days / 365) 31 | rem: days % 365 32 | rem: rem - (year / 4) + (year / 100) - (year / 1000) 33 | if rem < 0 [ 34 | until [ 35 | either PWAW-DT-leapyear? year [ 36 | rem: rem + 366 37 | ][ 38 | rem: rem + 365 39 | ] 40 | year: year - 1 41 | rem > -1 42 | ] 43 | ] 44 | d/year: year + 1 ;; year is the number of completed years 45 | ;; hence add one to get current year 46 | case [ 47 | rem = 0 [ 48 | d/year: d/year - 1 49 | d/month: 12 50 | d/day: 31 51 | ] 52 | rem < 60 [ 53 | either rem < 32 [ 54 | d/month: 1 55 | d/day: rem 56 | ][ 57 | d/month: 2 58 | d/day: rem - 31 59 | ] 60 | ] 61 | all [ 62 | rem = 60 63 | PWAW-DT-leapyear? d/year 64 | ][ 65 | d/month: 2 66 | d/day: 29 67 | ] 68 | rem > 59 [ 69 | if PWAW-DT-leapyear? d/year [rem: rem - 1] 70 | case [ 71 | rem < 91 [ 72 | d/month: 3 73 | d/day: rem - 59 74 | ] 75 | rem < 121 [ 76 | d/month: 4 77 | d/day: rem - 90 78 | ] 79 | rem < 152 [ 80 | d/month: 5 81 | d/day: rem - 120 82 | ] 83 | rem < 182 [ 84 | d/month: 6 85 | d/day: rem - 151 86 | ] 87 | rem < 213 [ 88 | d/month: 7 89 | d/day: rem - 181 90 | ] 91 | rem < 244 [ 92 | d/month: 8 93 | d/day: rem - 212 94 | ] 95 | rem < 274 [ 96 | d/month: 9 97 | d/day: rem - 243 98 | ] 99 | rem < 305 [ 100 | d/month: 10 101 | d/day: rem - 273 102 | ] 103 | rem < 335 [ 104 | d/month: 11 105 | d/day: rem - 304 106 | ] 107 | rem < 366 [ 108 | d/month: 12 109 | d/day: rem - 334 110 | ] 111 | true [ 112 | return 1 113 | ] 114 | ] 115 | ] 116 | ] 117 | 118 | 0 119 | ] 120 | 121 | -------------------------------------------------------------------------------- /UTF8/Tests/string-c-string-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "string-c-string unit tests" 3 | Author: "Peter W A Wood" 4 | File: %string-c-string-test.red 5 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt" 7 | ] 8 | 9 | #include %/Users/peter/VMShare/Languages/Red/quick-test/quick-test.red 10 | 11 | ~~~start-file~~~ "string to c-string" 12 | 13 | --test-- "scs1" 14 | scs1-r: routine: [ 15 | str [string!] 16 | return: [logic!] 17 | /local 18 | c-str [c-string!] 19 | ret-value [logic!] 20 | ][ 21 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/Core/PWAW-C-core.reds 22 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/UTF8/string-c-string.reds 23 | c-str: PWAW-string-c-string str 24 | ret-value: PWAW-C-str-equal? "hello world" c-str 25 | free as byte-ptr! c-str 26 | ret-value 27 | ] 28 | --assert scs1-r "hello world" 29 | 30 | --test-- "scs2" 31 | scs2-r: routine: [ 32 | str [string!] 33 | return: [logic!] 34 | /local 35 | c-str [c-string!] 36 | ret-value [logic!] 37 | ][ 38 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/Core/PWAW-C-core.reds 39 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/UTF8/string-c-string.reds 40 | c-str: PWAW-string-c-string str 41 | ret-value: PWAW-C-str-equal? {EspañolРусскийSlovenščina} c-str 42 | free as byte-ptr! c-str 43 | ret-value 44 | ] 45 | 46 | --assert scs2-r {EspañolРусскийSlovenščina} 47 | 48 | 49 | --test-- "scs3" 50 | scs3-r: routine: [ 51 | str [string!] 52 | return: [logic!] 53 | /local 54 | c-str [c-string!] 55 | expected [c-string!] 56 | ret-value [logic!] 57 | ][ 58 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/Core/PWAW-C-core.reds 59 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/UTF8/string-c-string.reds 60 | c-str: PWAW-string-c-string str 61 | expected: "𝄢" 62 | ret-value: PWAW-C-str-equal? expected c-str 63 | free as byte-ptr! c-str 64 | ret-value 65 | ] 66 | 67 | --assert scs3-r "^(01D122)" 68 | 69 | --test-- "scs4" 70 | scs4-r: routine: [ 71 | str [string!] 72 | return: [logic!] 73 | /local 74 | c-str [c-string!] 75 | expected [c-string!] 76 | ret-value [logic!] 77 | ][ 78 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/Core/PWAW-C-core.reds 79 | #include %/Users/peter/VMShare/Code/Red-System/Red-System-Libs/UTF8/string-c-string.reds 80 | c-str: PWAW-string-c-string str 81 | expected: {The bass clef - 𝄢} 82 | ret-value: PWAW-C-str-equal? expected c-str 83 | free as byte-ptr! c-str 84 | ret-value 85 | ] 86 | 87 | --assert scs4-r "The bass clef - ^(01D122)" 88 | 89 | ~~~end-file~~~ 90 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-date-time-libc.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "LibC module for date-time library" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011 - 2014 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | PWAW-DT-timeval!: alias struct! [ 11 | seconds [integer!] 12 | microseconds [integer!] 13 | ] 14 | 15 | PWAW-DT-tm!: alias struct! [ 16 | sec [integer!] 17 | min [integer!] 18 | hour [integer!] 19 | mday [integer!] 20 | mon [integer!] 21 | year [integer!] 22 | wday [integer!] 23 | yday [integer!] 24 | isdst [integer!] 25 | gmtoff [integer!] 26 | zone [c-string!] 27 | ] 28 | 29 | #import [ 30 | LIBC-FILE cdecl [ 31 | PWAW-DT-as-localtime: "localtime_r" [ 32 | time [pointer! [integer!]] 33 | result [PWAW-DT-tm!] 34 | return: [PWAW-DT-tm!] 35 | ] 36 | PWAW-DT-get-time-of-day: "gettimeofday" [ 37 | time-of-day [PWAW-DT-timeval!] 38 | timezone [struct! [ 39 | mins [integer!] 40 | dst [integer!] 41 | ]] 42 | return: [integer!] 43 | ] 44 | ] 45 | ] 46 | 47 | PWAW-DT-now: func [ 48 | {provides the current date/time} 49 | result [PWAW-DT-date!] 50 | {An initialised PWAW-DT-date! struct for the date/time} 51 | return: [integer!] 52 | { 0 - successful 53 | 1 - cannot retrieve time from os 54 | 2 - cannot convert the machine time 55 | 3 - cannot retrieve time zone 56 | } 57 | /local 58 | errcode [integer!] 59 | localtime [PWAW-DT-timeval!] 60 | tz [struct! [ 61 | mins [integer!] 62 | dst [integer!] 63 | ]] 64 | time [integer!] 65 | tm [PWAW-DT-tm!] 66 | ][ 67 | 68 | ;; local variables 69 | localtime: declare PWAW-DT-timeval! 70 | tz: declare struct! [ 71 | mins [integer!] 72 | dst [integer!] 73 | ] 74 | tm: declare PWAW-DT-tm! 75 | 76 | ;; get the machine time 77 | if 0 <> PWAW-DT-get-time-of-day localtime tz [ 78 | return 1 79 | ] 80 | time: localtime/seconds 81 | 82 | ;; expand the time into date & time info 83 | if null = PWAW-DT-as-localtime :time tm [return 2] 84 | 85 | ;; fill the date structure 86 | result/year: tm/year + 1900 87 | result/month: tm/mon + 1 88 | result/day: tm/mday 89 | result/hour: tm/hour 90 | result/minutes: tm/min 91 | result/seconds: tm/sec 92 | result/microseconds: localtime/microseconds 93 | result/tz-hours: tz/mins / 60 94 | result/tz-minutes: tz/mins % 60 95 | 96 | ;; successful return 97 | 0 98 | ] 99 | 100 | -------------------------------------------------------------------------------- /LibTom/LTM-mul-2d.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Shift left by a supplied number of bits" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | File: %libtommaths.reds 6 | Descripton: "A reduced implementation of LibTomMath authored by Tom St Denis" 7 | License: {Distributed under the Boost Software License, Version 1.0. 8 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 9 | ] 10 | 11 | #include %libtommaths.def 12 | #include %LTM-clamp.reds 13 | #include %LTM-grow.reds 14 | #include %LTM-lshd.reds 15 | 16 | LTM-mul-2d: func [ 17 | "Shift left by a supplied number of bits" 18 | a [LTM-int!] "Number to have the shift applied" 19 | bit-count [integer!] "Number of bits to shift" 20 | c [LTM-int!] "Shifted integer" 21 | return: [integer!] " LTM-OKAY or error code" 22 | /local 23 | bits-left [integer!] ;; Bits left to shift after digits 24 | carry [LTM-digit!] 25 | i [integer!] ;; loop counter 26 | mask [LTM-digit!] ;; Bitmask for carries 27 | next-carry [LTM-digit!] 28 | response [integer!] ;; Response from lib calls 29 | shift [integer!] ;; Number of bits to shift MSB 30 | ][ 31 | ;; copy a to c 32 | if (a <> c) [ 33 | response: LTM-copy a c 34 | if response <> LTM-OKAY [return response] 35 | ] 36 | 37 | ;; extend c if needed 38 | if c/alloc < (c/used + (bit-count / LTM-DIGIT-BIT) + 1) [ 39 | response: LTM-grow c (c/used + (bit-count / LTM-DIGIT-BIT) + 1) 40 | if response <> LTM-OKAY [return response] 41 | ] 42 | 43 | ;; first shift by the number of full digits in bit count 44 | if bit-count >= LTM-DIGIT-BIT [ 45 | response: LTM-lshd c (bit-count / LTM-DIGIT-BIT) 46 | if response <> LTM-OKAY [return response] 47 | ] 48 | 49 | ;; then shift by the number of bits remaining 50 | bits-left: bit-count % LTM-DIGIT-BIT 51 | if bits-left > 0 [ 52 | ;; calc bitmask for carries 53 | mask: as LTM-digit! (1 << bits-left) - 1 54 | 55 | ;; shift for MSBs 56 | shift: LTM-DIGIT-BIT - bits-left 57 | 58 | ;; initialise carry 59 | carry: as LTM-digit! 0 60 | 61 | ;; shift each of the digits, applying the carry 62 | i: 1 63 | until [ 64 | ;; get the higher bits of the current word (ie the next carry) 65 | next-carry: (c/mp-digit/i >> shift) and mask 66 | 67 | ;; shift the current digit and OR in the carry 68 | c/mp-digit/i: ((c/mp-digit/i << as LTM-digit! bits-left) or carry) and LTM-MASK 69 | 70 | ;; set the carry to the carry bits of the current digit 71 | carry: next-carry 72 | 73 | i: i + 1 74 | i > c/used 75 | ] 76 | 77 | ;; set the final carry 78 | if carry <> as LTM-digit! 0 [ 79 | c/used: c/used + 1 80 | i: c/used 81 | c/mp-digit/i: carry 82 | ] 83 | 84 | ] 85 | 86 | return LTM-clamp c ;; LTM-clamp returns LTM-OKAY 87 | ] -------------------------------------------------------------------------------- /I64/Tests/shift-right-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - shift right test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-shift-right.reds 10 | 11 | ~~~start-file~~~ "shift-right" 12 | 13 | --test-- "shift-right-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 1 16 | a/most-sig: 0 17 | b: declare PWAW-I64-int64! 18 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a b 1 19 | --assert b/least-sig = 0 20 | --assert b/most-sig = 0 21 | 22 | --test-- "shift-right-2" 23 | a: declare PWAW-I64-int64! 24 | a/least-sig: 15 25 | a/most-sig: 0 26 | b: declare PWAW-I64-int64! 27 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a b 3 28 | --assert b/least-sig = 1 29 | --assert b/most-sig = 0 30 | 31 | --test-- "shift-right-3" 32 | a: declare PWAW-I64-int64! 33 | a/least-sig: 0 34 | a/most-sig: 1 35 | b: declare PWAW-I64-int64! 36 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a b 1 37 | --assert b/least-sig = 80000000h 38 | --assert b/most-sig = 0 39 | 40 | --test-- "shift-right-4" 41 | a: declare PWAW-I64-int64! 42 | a/least-sig: 0 43 | a/most-sig: 1 44 | b: declare PWAW-I64-int64! 45 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a b 9 46 | --assert b/least-sig = 00800000h 47 | --assert b/most-sig = 0 48 | 49 | --test-- "shift-right-5" 50 | a: declare PWAW-I64-int64! 51 | a/least-sig: 0 52 | a/most-sig: 2 53 | b: declare PWAW-I64-int64! 54 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a b 2 55 | --assert b/least-sig = 80000000h 56 | --assert b/most-sig = 0 57 | 58 | --test-- "shift-right-6" 59 | a: declare PWAW-I64-int64! 60 | a/least-sig: 0 61 | a/most-sig: 2 62 | b: declare PWAW-I64-int64! 63 | --assert PWAW-I64-EXCESSIVE-SHIFT = PWAW-I64-shift-right a b 64 64 | 65 | --test-- "shift-right-7" 66 | a: declare PWAW-I64-int64! 67 | a/least-sig: 0 68 | a/most-sig: 1 69 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a a 1 70 | --assert a/least-sig = 80000000h 71 | --assert a/most-sig = 0 72 | 73 | --test-- "shift-right-8" 74 | a: declare PWAW-I64-int64! 75 | a/least-sig: 0 76 | a/most-sig: 1 77 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a a 0 78 | --assert a/least-sig = 0 79 | --assert a/most-sig = 1 80 | 81 | --test-- "shift-right-9" 82 | a: declare PWAW-I64-int64! 83 | a/least-sig: 80000000h 84 | a/most-sig: 0 85 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a a 1 86 | --assert a/least-sig = 40000000h 87 | --assert a/most-sig = 0 88 | 89 | --test-- "shift-right-10" 90 | a: declare PWAW-I64-int64! 91 | a/least-sig: 0 92 | a/most-sig: 80000000h 93 | --assert PWAW-I64-OKAY = PWAW-I64-shift-right a a 63 94 | --assert a/least-sig = 1 95 | --assert a/most-sig = 0 96 | 97 | ~~~end-file~~~ 98 | 99 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-compare-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "compare" 4 | 5 | --test-- "mp-cmp1" 6 | mp-cmp1-mp-int1: declare LTM-int! 7 | response: LTM-init mp-cmp1-mp-int1 8 | --assert response = LTM-OKAY 9 | mp-cmp1-mp-int2: declare LTM-int! 10 | response: LTM-init mp-cmp1-mp-int2 11 | --assert response = LTM-OKAY 12 | response: LTM-cmp mp-cmp1-mp-int1 mp-cmp1-mp-int2 13 | --assert response = LTM-EQ 14 | 15 | --test-- "mp-cmp2" 16 | mp-cmp2-mp-int1: declare LTM-int! 17 | response: LTM-init mp-cmp2-mp-int1 18 | mp-cmp2-mp-int1/used: 1 19 | mp-cmp2-mp-int1/mp-digit/value: #"^(01)" 20 | mp-cmp2-mp-int1/sign: LTM-NEG 21 | --assert response = LTM-OKAY 22 | mp-cmp2-mp-int2: declare LTM-int! 23 | response: LTM-init mp-cmp2-mp-int2 24 | --assert response = LTM-OKAY 25 | response: LTM-cmp mp-cmp2-mp-int1 mp-cmp2-mp-int2 26 | --assert response = LTM-LT 27 | 28 | --test-- "mp-cmp3" 29 | mp-cmp3-mp-int1: declare LTM-int! 30 | response: LTM-init mp-cmp3-mp-int1 31 | mp-cmp3-mp-int1/used: 1 32 | mp-cmp3-mp-int1/mp-digit/value: #"^(01)" 33 | --assert response = LTM-OKAY 34 | mp-cmp3-mp-int2: declare LTM-int! 35 | response: LTM-init mp-cmp3-mp-int2 36 | mp-cmp3-mp-int2/sign: LTM-NEG 37 | mp-cmp3-mp-int2/used: 2 38 | mp-cmp3-bp: mp-cmp3-mp-int2/mp-digit 39 | mp-cmp3-bp: mp-cmp3-bp + 1 40 | mp-cmp3-bp/value: #"^(7F)" 41 | --assert response = LTM-OKAY 42 | response: LTM-cmp mp-cmp3-mp-int1 mp-cmp3-mp-int2 43 | --assert response = LTM-GT 44 | 45 | --test-- "mp-cmp4" 46 | mp-cmp4-mp-int1: declare LTM-int! 47 | response: LTM-init mp-cmp4-mp-int1 48 | mp-cmp4-mp-int1/used: 1 49 | mp-cmp4-mp-int1/sign: LTM-NEG 50 | mp-cmp4-mp-int1/mp-digit/value: #"^(7F)" 51 | --assert response = LTM-OKAY 52 | mp-cmp4-mp-int2: declare LTM-int! 53 | response: LTM-init mp-cmp4-mp-int2 54 | --assert response = LTM-OKAY 55 | mp-cmp4-mp-int2/used: 1 56 | mp-cmp4-mp-int2/sign: LTM-NEG 57 | mp-cmp4-mp-int2/mp-digit/value: #"^(7F)" 58 | response: LTM-cmp mp-cmp4-mp-int1 mp-cmp4-mp-int2 59 | --assert response = LTM-EQ 60 | 61 | --test-- "mp-cmp5" 62 | mp-cmp5-mp-int1: declare LTM-int! 63 | response: LTM-init mp-cmp5-mp-int1 64 | mp-cmp5-mp-int1/used: 1 65 | mp-cmp5-mp-int1/mp-digit/value: #"^(7F)" 66 | --assert response = LTM-OKAY 67 | mp-cmp5-mp-int2: declare LTM-int! 68 | response: LTM-init mp-cmp5-mp-int2 69 | --assert response = LTM-OKAY 70 | mp-cmp5-mp-int2/used: 1 71 | mp-cmp5-mp-int2/mp-digit/value: #"^(7E)" 72 | response: LTM-cmp mp-cmp5-mp-int1 mp-cmp5-mp-int2 73 | --assert response = LTM-GT 74 | 75 | --test-- "mp-cmp5" 76 | mp-cmp5-mp-int1: declare LTM-int! 77 | response: LTM-init mp-cmp5-mp-int1 78 | --assert response = LTM-OKAY 79 | mp-cmp5-mp-int2: declare LTM-int! 80 | response: LTM-init mp-cmp5-mp-int2 81 | --assert response = LTM-OKAY 82 | mp-cmp5-mp-int2/used: 1 83 | mp-cmp5-mp-int2/sign: LTM-NEG 84 | mp-cmp5-mp-int2/mp-digit/value: #"^(01)" 85 | response: LTM-cmp mp-cmp5-mp-int1 mp-cmp5-mp-int2 86 | --assert response = LTM-GT 87 | 88 | ===end-group=== 89 | 90 | -------------------------------------------------------------------------------- /DateTime/PWAW-DT-mold-date.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "Mold a date" 3 | Author: "Peter W A Wood" 4 | Version: 0.2.0 5 | Rights: "Copyright © 2011-2103 Peter W A Wood. All rights reserved." 6 | License: "Distributed under the Boost Software License, Version 1.0." 7 | "See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt" 8 | ] 9 | 10 | #include %../Core/PWAW-C-core.reds 11 | 12 | #include %PWAW-DT-date-def.reds 13 | 14 | PWAW-DT-mold-date: func [ 15 | {Provides a string representation of a date} 16 | d [PWAW-DT-date!] {the date} 17 | md [c-string!] 18 | {a string of at least 26 characters in 19 | which the molded date will be returned} 20 | return: [integer!] 21 | { 0 - successful 22 | 1 - provided string too short 23 | 2 - invalid month 24 | } 25 | /local 26 | i [integer!] 27 | pos [integer!] 28 | ][ 29 | if 26 > length? md [return 1] 30 | pos: 1 31 | PWAW-C-mold-int d/day md 32 | either d/day < 10 [md: md + 1] [md: md + 2] 33 | md/1: #"-" 34 | md: md + 1 35 | switch d/month [ 36 | 1 [PWAW-DT-push-month md #"J" #"a" #"n"] 37 | 2 [PWAW-DT-push-month md #"F" #"e" #"b"] 38 | 3 [PWAW-DT-push-month md #"M" #"a" #"r"] 39 | 4 [PWAW-DT-push-month md #"A" #"p" #"r"] 40 | 5 [PWAW-DT-push-month md #"M" #"a" #"y"] 41 | 6 [PWAW-DT-push-month md #"J" #"u" #"n"] 42 | 7 [PWAW-DT-push-month md #"J" #"u" #"l"] 43 | 8 [PWAW-DT-push-month md #"A" #"u" #"g"] 44 | 9 [PWAW-DT-push-month md #"S" #"e" #"p"] 45 | 10 [PWAW-DT-push-month md #"O" #"c" #"t"] 46 | 11 [PWAW-DT-push-month md #"N" #"o" #"v"] 47 | 12 [PWAW-DT-push-month md #"D" #"e" #"c"] 48 | default [return 2] 49 | ] 50 | md: md + 3 51 | md/1: #"-" 52 | md: md + 1 53 | PWAW-C-mold-int d/year md 54 | md: md + 4 55 | md/1: #"/" 56 | md: md + 1 57 | PWAW-DT-push-two-digits d/hour md 58 | md: md + 2 59 | md/1: #":" 60 | md: md + 1 61 | PWAW-DT-push-two-digits d/minutes md 62 | md: md + 2 63 | md/1: #":" 64 | md: md + 1 65 | PWAW-DT-push-two-digits d/seconds md 66 | md: md + 2 67 | ;; Note: a time zone with 0 hours and 68 | ;; negative minutes would be incorrectly 69 | ;; molded. There is currently no such 70 | ;; time zone. 71 | either d/tz-hours >= 0 [ 72 | md/1: #"+" 73 | md: md + 1 74 | ][ 75 | md/1: #"v" ;; write over the null-byte added by 76 | ;; mold-int 77 | ] 78 | PWAW-C-mold-int d/tz-hours md 79 | case [ 80 | d/tz-hours < -9 [md: md + 3] 81 | d/tz-hours < 0 [md: md + 2] 82 | d/tz-hours > 10 [md: md + 2] 83 | true [md: md + 1] 84 | ] 85 | md/1: #":" 86 | md: md + 1 87 | PWAW-DT-push-two-digits d/tz-minutes md 88 | 89 | 0 90 | ] 91 | -------------------------------------------------------------------------------- /I64/README.md: -------------------------------------------------------------------------------- 1 | # I64 - Basic 64-bit Integer Arithmetic 2 | 3 | I wrote this library to be able to handle aritmetic on 64-bit integers returned from external source such as Window's APIs. It is an interim library as I expect that Red/System 2 will have built in support for 64-bit integers.It provides basic addition, subtraction, multiplication and division and not much else. It uses simple algorithms and hasn't been optimised but it is sufficient for my current needs. 4 | 5 | ## The int64! structure - PWAW-I64-int64! 6 | 7 | This is a structure containing two members which are both of the integer! type. One is called most-sig, the other least-sig. 8 | 9 | Declaring and initialising an int64! 10 | ``` 11 | my-int64: declare PWAW-I64-int64! 12 | my-int64/most-sig: 0 13 | my-int64/least-sig: FFFFFFFFh 14 | ``` 15 | ## Available Defines and Variables 16 | 17 | The library includes a number of helpful defines and a couple of useful variables. 18 | 19 | ### Function Return Status Codes 20 | 21 | The library uses the following function return status codes which are integers: 22 | ``` 23 | #define PWAW-I64-OKAY 0 24 | #define PWAW-I64-OVERFLOW 1 25 | #define PWAW-I64-INVALID-ARG 2 26 | #define PWAW-I64-EXCESSIVE-SHIFT 3 27 | #define PWAW-I64-ZERO-DIVIDE 4 28 | ``` 29 | 30 | ### PWAW-I64-zero 31 | 32 | An int64! initialised to zero. 33 | 34 | ### PWAW-I64-one 35 | 36 | An int64! initialised to one. 37 | 38 | ### PWAW-I64-copy(a b) 39 | 40 | A macro which copies the value of one int64! to another. 41 | 42 | ### PWAW-I64-equal?(a b) 43 | 44 | A macro which tests if two int64!s are equal. It will evelaute to true if they are and false if they are not. 45 | 46 | ### PWAW-I64-nagative?(a) 47 | 48 | A macro which checks if an int64! is negative. 49 | 50 | 51 | ### PWAW-I64-positive? 52 | 53 | A macro which checks if an int64! is positive. 54 | 55 | ### PWAW-I64-zero? 56 | 57 | A macro which checks if an int64! is zero. 58 | 59 | ### PWAW-I64-zero-int64(a) 60 | 61 | A macro which sets the value of an int64! to zero. 62 | 63 | ## Functions 64 | 65 | The library includes the following public functions and a handful of supporting functions. 66 | 67 | ### PWAW-I64-add a b c 68 | 69 | This function adds a to b and places the result into c. All three are int64!s. The function returns one of the Function Return Status Codes. 70 | 71 | ### PWAW-I64-div a b c d 72 | 73 | This function divides a by b, places the result into c, and the remainder into d. All three are int64!s. The function returns one of the Function Return Status Codes. 74 | 75 | ### PWAW-I64-sub a b c 76 | 77 | This function subtracts b from a and places the result into c. All three are int64!s. The function returns one of the Function Return Status Codes. 78 | 79 | ### PwAW-I64-greater? a b 80 | 81 | This functions returns true if a is greater than b, otherwise it returns false. 82 | 83 | ### PWAW-I64-mul a b c 84 | 85 | This function multiplies a and b and places the result into c. All three are int64!s. The function returns one of the Function Return Status Codes. 86 | -------------------------------------------------------------------------------- /DateTime/Tests/load-date-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - load-date test script" 3 | Author: "Peter W A Wood" 4 | File: %load-date-test.reds 5 | Rights: "Copyright (C) 2012 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-DT-date-time.reds 11 | 12 | ~~~start-file~~~ "load-date" 13 | 14 | --test-- "ld-1" 15 | d: declare PWAW-DT-date! 16 | r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" d 17 | --assert r = 0 18 | --assert d/year = 2012 19 | --assert d/month = 1 20 | --assert d/day = 13 21 | --assert d/hour = 16 22 | --assert d/minutes = 46 23 | --assert d/seconds = 27 24 | --assert d/microseconds = 0 25 | --assert d/tz-hours = 8 26 | --assert d/tz-minutes = 30 27 | md: "abcdefghijklmnopqrstuvwxy" 28 | 29 | --test-- "ld-2" 30 | d: declare PWAW-DT-date! 31 | r: PWAW-DT-load-date "31-Jan-1997/16:46:27-08:00" d 32 | --assert r = 0 33 | ;--assert d/year = 1997 34 | ;--assert d/month = 1 35 | ;--assert d/day = 31 36 | ;--assert d/hour = 16 37 | ;--assert d/minutes = 46 38 | ;--assert d/seconds = 27 39 | ;--assert d/microseconds = 0 40 | ;--assert d/tz-hours = -8 41 | ;--assert d/tz-minutes = 0 42 | 43 | --test-- "ld-3" 44 | d: declare PWAW-DT-date! 45 | --assert 1 = PWAW-DT-load-date "32-Jan-1997/16:46:27-08:00" d 46 | 47 | --test-- "ld-4" 48 | d: declare PWAW-DT-date! 49 | --assert 1 = PWAW-DT-load-date "00-Jan-1997/16:46:27-08:00" d 50 | 51 | --test-- "ld-5" 52 | d: declare PWAW-DT-date! 53 | --assert 1 = PWAW-DT-load-date "aa-Jan-1997/16:46:27-08:00" d 54 | 55 | --test-- "ld-6" 56 | d: declare PWAW-DT-date! 57 | --assert 2 = PWAW-DT-load-date "31-Jon-1997/16:46:27-08:00" d 58 | 59 | --test-- "ld-7" 60 | d: declare PWAW-DT-date! 61 | --assert 3 = PWAW-DT-load-date "31-Jan--997/16:46:27-08:00" d 62 | 63 | --test-- "ld-8" 64 | d: declare PWAW-DT-date! 65 | --assert 7 = PWAW-DT-load-date "31-Jan-1997/16:46:27-08:01" d 66 | 67 | --test-- "ld-9" 68 | d: declare PWAW-DT-date! 69 | --assert 7 = PWAW-DT-load-date "31-Jan-1997/16:46:27+19:00" d 70 | 71 | --test-- "ld-8" 72 | d: declare PWAW-DT-date! 73 | --assert 8 = PWAW-DT-load-date "29-Feb-1900/16:46:27-08:00" d 74 | 75 | --test-- "ld-9" 76 | d: declare PWAW-DT-date! 77 | --assert 0 = PWAW-DT-load-date "29-Feb-2000/16:46:27-08:00" d 78 | 79 | --test-- "ld-10" 80 | d: declare PWAW-DT-date! 81 | --assert 0 = PWAW-DT-load-date "29-Feb-2012/16:46:27-08:00" d 82 | 83 | --test-- "ld-11" 84 | d: declare PWAW-DT-date! 85 | --assert 8 = PWAW-DT-load-date "29-Feb-2011/16:46:27-08:00" d 86 | 87 | --test-- "ld-12" 88 | d: declare PWAW-DT-date! 89 | --assert 8 = PWAW-DT-load-date "31-Apr-2012/16:46:27-08:00" d 90 | 91 | --test-- "ld-13" 92 | d: declare PWAW-DT-date! 93 | --assert 0 = PWAW-DT-load-date "31-Jul-2012/16:46:27-08:00" d 94 | 95 | ~~~end-file~~~ 96 | 97 | -------------------------------------------------------------------------------- /I64/Tests/sub-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - sub test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-sub.reds 10 | 11 | ~~~start-file~~~ "sub" 12 | 13 | --test-- "sub-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 0 16 | a/most-sig: 1 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 1 19 | b/most-sig: 0 20 | c: declare PWAW-I64-int64! 21 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 22 | --assert c/least-sig = FFFFFFFFh 23 | --assert c/most-sig = 0 24 | 25 | --test-- "sub-2" 26 | a: declare PWAW-I64-int64! 27 | a/least-sig: FFFFFFFFh 28 | a/most-sig: 0 29 | b: declare PWAW-I64-int64! 30 | b/least-sig: 1 31 | b/most-sig: 0 32 | c: declare PWAW-I64-int64! 33 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 34 | --assert c/least-sig = FFFFFFFEh 35 | --assert c/most-sig = 0 36 | 37 | --test-- "sub-3" 38 | a: declare PWAW-I64-int64! 39 | a/least-sig: 100 40 | a/most-sig: 0 41 | b: declare PWAW-I64-int64! 42 | b/least-sig: 1 43 | b/most-sig: 0 44 | c: declare PWAW-I64-int64! 45 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 46 | --assert c/least-sig = 99 47 | --assert c/most-sig = 0 48 | 49 | --test-- "sub-4" 50 | a: declare PWAW-I64-int64! 51 | a/least-sig: FFFFFFFFh 52 | a/most-sig: 7FFFFFFFh 53 | b: declare PWAW-I64-int64! 54 | b/least-sig: 1 55 | b/most-sig: 0 56 | c: declare PWAW-I64-int64! 57 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 58 | --assert c/least-sig = FFFFFFFEh 59 | --assert c/most-sig = 7FFFFFFFh 60 | 61 | --test-- "sub-5" 62 | a: declare PWAW-I64-int64! 63 | a/least-sig: FFFFFFFFh 64 | a/most-sig: 7FFFFFFFh 65 | b: declare PWAW-I64-int64! 66 | b/least-sig: FFFFFFFEh 67 | b/most-sig: FFFFFFFFh 68 | c: declare PWAW-I64-int64! 69 | --assert PWAW-I64-OVERFLOW = PWAW-I64-sub a b c 70 | 71 | --test-- "sub-6" 72 | a: declare PWAW-I64-int64! 73 | a/least-sig: 2 74 | a/most-sig: 0 75 | b: declare PWAW-I64-int64! 76 | b/least-sig: FFFFFFFFh 77 | b/most-sig: FFFFFFFFh 78 | c: declare PWAW-I64-int64! 79 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 80 | --assert c/least-sig = 3 81 | --assert c/most-sig = 0 82 | 83 | --test-- "sub-7" 84 | a: declare PWAW-I64-int64! 85 | a/least-sig: 1 86 | a/most-sig: 0 87 | b: declare PWAW-I64-int64! 88 | b/least-sig: FFFFFFFEh 89 | b/most-sig: FFFFFFFFh 90 | c: declare PWAW-I64-int64! 91 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 92 | --assert c/least-sig = 3 93 | --assert c/most-sig = 0 94 | 95 | --test-- "sub-8" 96 | a: declare PWAW-I64-int64! 97 | a/least-sig: FFFFFFFFh 98 | a/most-sig: FFFFFFFFh 99 | b: declare PWAW-I64-int64! 100 | b/least-sig: FFFFFFFFh 101 | b/most-sig: FFFFFFFFh 102 | c: declare PWAW-I64-int64! 103 | --assert PWAW-I64-OKAY = PWAW-I64-sub a b c 104 | --assert c/least-sig = 0 105 | --assert c/most-sig = 0 106 | 107 | ~~~end-file~~~ 108 | 109 | -------------------------------------------------------------------------------- /LibTom/LTM-s-add.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Purpose: "low level addition - absolute values" 3 | Author: "PeterWAWood" 4 | Version: 0.1.0 5 | License: {Distributed under the Boost Software License, Version 1.0. 6 | See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt} 7 | ] 8 | 9 | #include %libtommaths.def 10 | 11 | LTM-s-add: func [ 12 | "low level addition - absolute values" 13 | a [LTM-int!] "The first integer of the addition" 14 | b [LTM-int!] "The second" 15 | c [LTM-int!] "The responseult of the addition" 16 | return: [integer!] "LTM-OKAY or an error code" 17 | /local 18 | carry [LTM-digit!] ;; carry digit 19 | i [integer!] ;; counter 20 | min [integer!] ;; min number of digits 21 | max [integer!] ;; max number of digits 22 | oldused [integer!] ;; value of c/used at start 23 | response [integer!] ;; call responseponse code 24 | x [LTM-int!] ;; used to point to larger of the 2 mp-int! 25 | ][ 26 | 27 | ;; find sizes and point x at the larger of the inputs 28 | either a/used > b/used [ 29 | min: b/used 30 | max: a/used 31 | x: a 32 | ][ 33 | min: a/used 34 | max: b/used 35 | x: b 36 | ] 37 | 38 | ;; extend the responseult if needed 39 | if c/alloc < (max + 1) [ 40 | response: LTM-grow c (max + 1) 41 | if response <> LTM-OKAY [return response] 42 | ] 43 | 44 | ;; get old used digit count and set new one 45 | oldused: c/used 46 | c/used: max + 1 47 | 48 | ;; zero the carry 49 | carry: as LTM-digit! 0 50 | 51 | ;; perform the addition 52 | 53 | ;;add the digits which both numbers have 54 | ;; compute sum one digit at a time 55 | i: 1 56 | until [ 57 | ;; Sum[i] = A[i] + B[i] + Carry 58 | c/mp-digit/i: a/mp-digit/i + b/mp-digit/i + carry 59 | 60 | ;; carry = carry bit of Sum[i] 61 | carry: c/mp-digit/i >>> LTM-DIGIT-BIT 62 | 63 | ;; take away carry bit from Sum[i] 64 | c/mp-digit/i: c/mp-digit/i and LTM-MASK 65 | 66 | ;; increment counter and pointers 67 | i: i + 1 68 | 69 | i > min 70 | ] 71 | 72 | ;; now copy the "higher" digits, remembering to carry where needed 73 | if max > min [ 74 | i: min + 1 75 | until [ 76 | ;; add each digit with the carry 77 | c/mp-digit/i: x/mp-digit/i + carry 78 | 79 | ;; get carry for next digit 80 | carry: c/mp-digit/i >>> LTM-DIGIT-BIT 81 | 82 | ;; take away carry from Sum[i] 83 | c/mp-digit/i: c/mp-digit/i and LTM-MASK 84 | 85 | i: i + 1 86 | 87 | i > max 88 | ] 89 | ] 90 | 91 | ;; add in the last carry 92 | ;; no need to check for non-zero as any leanding zeroes will be removed by 93 | ;; calling clamp 94 | i: max + 1 95 | c/mp-digit/i: carry 96 | 97 | ;; clear any digits in responseult that may have been left over 98 | if oldused > max [ LTM-zero-set(b/mp-digit (max + 1) oldused)] 99 | 100 | ;; remove any leading zeros 101 | ;; clamp will return okay or an error 102 | LTM-clamp c 103 | 104 | ] 105 | -------------------------------------------------------------------------------- /DateTime/Tests/date-difference-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System date-time library - date-difference test script" 3 | Author: "Peter W A Wood" 4 | File: %date-difference-test.reds 5 | Rights: "Copyright (C) 2012-2013 Peter W A Wood. All rights reserved." 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 7 | ] 8 | 9 | #include %../../quick-test.reds 10 | #include %../PWAW-DT-date-time.reds 11 | 12 | ~~~start-file~~~ "date-difference" 13 | 14 | dd-date1: declare PWAW-DT-date! 15 | dd-date2: declare PWAW-DT-date! 16 | dd-dur: declare PWAW-DT-duration! 17 | 18 | --test-- "dd-1" 19 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 20 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date2 21 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 22 | --assert 0 = dd-dur/days 23 | --assert 0 = dd-dur/hours 24 | --assert 0 = dd-dur/minutes 25 | --assert 0 = dd-dur/seconds 26 | --assert 0 = dd-dur/microseconds 27 | 28 | --test-- "dd-2" 29 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 30 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:28+08:30" dd-date2 31 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 32 | --assert 0 = dd-dur/days 33 | --assert 0 = dd-dur/hours 34 | --assert 0 = dd-dur/minutes 35 | --assert 1 = dd-dur/seconds 36 | --assert 0 = dd-dur/microseconds 37 | 38 | 39 | --test-- "dd-3" 40 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 41 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:26+08:30" dd-date2 42 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 43 | --assert 0 = dd-dur/days 44 | --assert 0 = dd-dur/hours 45 | --assert 0 = dd-dur/minutes 46 | --assert 1 = dd-dur/seconds 47 | --assert 0 = dd-dur/microseconds 48 | 49 | --test-- "dd-4" 50 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 51 | dd-r: PWAW-DT-load-date "13-Jan-2012/15:46:27+08:30" dd-date2 52 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 53 | --assert 0 = dd-dur/days 54 | --assert 1 = dd-dur/hours 55 | --assert 0 = dd-dur/minutes 56 | --assert 0 = dd-dur/seconds 57 | --assert 0 = dd-dur/microseconds 58 | 59 | --test-- "dd-5" 60 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 61 | dd-r: PWAW-DT-load-date "12-Jan-2012/15:45:26+08:30" dd-date2 62 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 63 | --assert 1 = dd-dur/days 64 | --assert 1 = dd-dur/hours 65 | --assert 1 = dd-dur/minutes 66 | --assert 1 = dd-dur/seconds 67 | --assert 0 = dd-dur/microseconds 68 | 69 | --test-- "dd-6" 70 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 71 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+09:30" dd-date2 72 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 73 | --assert 0 = dd-dur/days 74 | --assert 1 = dd-dur/hours 75 | --assert 0 = dd-dur/minutes 76 | --assert 0 = dd-dur/seconds 77 | --assert 0 = dd-dur/microseconds 78 | 79 | --test-- "dd-7" 80 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:30" dd-date1 81 | dd-r: PWAW-DT-load-date "13-Jan-2012/16:46:27+08:15" dd-date2 82 | --assert 0 = PWAW-DT-date-difference dd-date1 dd-date2 dd-dur 83 | --assert 0 = dd-dur/days 84 | --assert 0 = dd-dur/hours 85 | --assert 15 = dd-dur/minutes 86 | --assert 0 = dd-dur/seconds 87 | --assert 0 = dd-dur/microseconds 88 | 89 | ~~~end-file~~~ 90 | 91 | -------------------------------------------------------------------------------- /I64/Tests/abs-add-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - absolute add test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-abs-add.reds 10 | 11 | ~~~start-file~~~ "abs-add" 12 | 13 | --test-- "abs-add-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 0 16 | a/most-sig: 1 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 1 19 | b/most-sig: 0 20 | c: declare PWAW-I64-int64! 21 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b c 22 | --assert c/least-sig = 1 23 | --assert c/most-sig = 1 24 | 25 | --test-- "abs-add-2" 26 | a: declare PWAW-I64-int64! 27 | a/least-sig: FFFFFFFFh 28 | a/most-sig: 0 29 | b: declare PWAW-I64-int64! 30 | b/least-sig: 1 31 | b/most-sig: 0 32 | c: declare PWAW-I64-int64! 33 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b c 34 | --assert c/least-sig = 0 35 | --assert c/most-sig = 1 36 | --test-- "abs-add-3" 37 | a: declare PWAW-I64-int64! 38 | a/least-sig: 1 39 | a/most-sig: 0 40 | b: declare PWAW-I64-int64! 41 | b/least-sig: 1 42 | b/most-sig: 0 43 | c: declare PWAW-I64-int64! 44 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b c 45 | --assert c/least-sig = 2 46 | --assert c/most-sig = 0 47 | 48 | --test-- "abs-add-4" 49 | a: declare PWAW-I64-int64! 50 | a/least-sig: FFFFFFFFh 51 | a/most-sig: 7FFFFFFFh 52 | b: declare PWAW-I64-int64! 53 | b/least-sig: 1 54 | b/most-sig: 0 55 | c: declare PWAW-I64-int64! 56 | --assert PWAW-I64-OVERFLOW = PWAW-I64-abs-add a b c 57 | --assert c/least-sig = 0 58 | --assert c/most-sig = 80000000h 59 | 60 | --test-- "abs-add-5" 61 | a: declare PWAW-I64-int64! 62 | a/least-sig: FFFFFFFFh 63 | a/most-sig: 7FFFFFFFh 64 | b: declare PWAW-I64-int64! 65 | b/least-sig: 2 66 | b/most-sig: 0 67 | c: declare PWAW-I64-int64! 68 | --assert PWAW-I64-OVERFLOW = PWAW-I64-abs-add a b c 69 | --assert c/least-sig = 1 70 | --assert c/most-sig = 80000000h 71 | 72 | --test-- "abs-add-6" 73 | a: declare PWAW-I64-int64! 74 | a/least-sig: 1 75 | a/most-sig: 0 76 | b: declare PWAW-I64-int64! 77 | b/least-sig: 1 78 | b/most-sig: 0 79 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b a 80 | --assert a/least-sig = 2 81 | --assert a/most-sig = 0 82 | 83 | --test-- "abs-add-7" 84 | a: declare PWAW-I64-int64! 85 | a/least-sig: 1 86 | a/most-sig: 1 87 | b: declare PWAW-I64-int64! 88 | b/least-sig: 1 89 | b/most-sig: 1 90 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b a 91 | --assert a/least-sig = 2 92 | --assert a/most-sig = 2 93 | 94 | --test-- "abs-add-8" 95 | a: declare PWAW-I64-int64! 96 | a/least-sig: 10000000h 97 | a/most-sig: 0 98 | b: declare PWAW-I64-int64! 99 | b/least-sig: 80000000h 100 | b/most-sig: 0 101 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b a 102 | --assert a/least-sig = 90000000h 103 | --assert a/most-sig = 0 104 | 105 | --test-- "abs-add-9" 106 | a: declare PWAW-I64-int64! 107 | a/least-sig: 80000000h 108 | a/most-sig: 0 109 | b: declare PWAW-I64-int64! 110 | b/least-sig: 04000000h 111 | b/most-sig: 0 112 | --assert PWAW-I64-OKAY = PWAW-I64-abs-add a b a 113 | --assert a/least-sig = 84000000h 114 | --assert a/most-sig = 0 115 | 116 | ~~~end-file~~~ 117 | 118 | -------------------------------------------------------------------------------- /I64/Tests/add-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System Int64 library - add test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2014 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-I64-add.reds 10 | 11 | ~~~start-file~~~ "add" 12 | 13 | --test-- "add-1" 14 | a: declare PWAW-I64-int64! 15 | a/least-sig: 0 16 | a/most-sig: 1 17 | b: declare PWAW-I64-int64! 18 | b/least-sig: 1 19 | b/most-sig: 0 20 | c: declare PWAW-I64-int64! 21 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 22 | --assert c/least-sig = 1 23 | --assert c/most-sig = 1 24 | 25 | --test-- "add-2" 26 | a: declare PWAW-I64-int64! 27 | a/least-sig: FFFFFFFFh 28 | a/most-sig: 0 29 | b: declare PWAW-I64-int64! 30 | b/least-sig: 1 31 | b/most-sig: 0 32 | c: declare PWAW-I64-int64! 33 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 34 | --assert c/least-sig = 0 35 | --assert c/most-sig = 1 36 | 37 | --test-- "add-3" 38 | a: declare PWAW-I64-int64! 39 | a/least-sig: 1 40 | a/most-sig: 0 41 | b: declare PWAW-I64-int64! 42 | b/least-sig: 1 43 | b/most-sig: 0 44 | c: declare PWAW-I64-int64! 45 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 46 | --assert c/least-sig = 2 47 | --assert c/most-sig = 0 48 | 49 | --test-- "add-4" 50 | a: declare PWAW-I64-int64! 51 | a/least-sig: FFFFFFFFh 52 | a/most-sig: 7FFFFFFFh 53 | b: declare PWAW-I64-int64! 54 | b/least-sig: 1 55 | b/most-sig: 0 56 | c: declare PWAW-I64-int64! 57 | --assert PWAW-I64-OVERFLOW = PWAW-I64-add a b c 58 | --assert c/least-sig = 0 59 | --assert c/most-sig = 80000000h 60 | 61 | --test-- "add-5" 62 | a: declare PWAW-I64-int64! 63 | a/least-sig: FFFFFFFFh 64 | a/most-sig: 7FFFFFFFh 65 | b: declare PWAW-I64-int64! 66 | b/least-sig: 2 67 | b/most-sig: 0 68 | c: declare PWAW-I64-int64! 69 | --assert PWAW-I64-OVERFLOW = PWAW-I64-add a b c 70 | --assert c/least-sig = 1 71 | --assert c/most-sig = 80000000h 72 | 73 | --test-- "add-6" 74 | a: declare PWAW-I64-int64! 75 | a/least-sig: 2 76 | a/most-sig: 0 77 | b: declare PWAW-I64-int64! 78 | b/least-sig: FFFFFFFFh 79 | b/most-sig: FFFFFFFFh 80 | c: declare PWAW-I64-int64! 81 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 82 | --assert c/least-sig = 1 83 | --assert c/most-sig = 0 84 | 85 | --test-- "add-7" 86 | a: declare PWAW-I64-int64! 87 | a/least-sig: 1 88 | a/most-sig: 0 89 | b: declare PWAW-I64-int64! 90 | b/least-sig: FFFFFFFEh 91 | b/most-sig: FFFFFFFFh 92 | c: declare PWAW-I64-int64! 93 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 94 | --assert c/least-sig = FFFFFFFFh 95 | --assert c/most-sig = FFFFFFFFh 96 | 97 | --test-- "add-8" 98 | a: declare PWAW-I64-int64! 99 | a/least-sig: FFFFFFFFh 100 | a/most-sig: FFFFFFFFh 101 | b: declare PWAW-I64-int64! 102 | b/least-sig: FFFFFFFFh 103 | b/most-sig: FFFFFFFFh 104 | c: declare PWAW-I64-int64! 105 | --assert PWAW-I64-OKAY = PWAW-I64-add a b c 106 | --assert c/least-sig = FFFFFFFEh 107 | --assert c/most-sig = FFFFFFFFh 108 | 109 | --test-- "add-9" 110 | a: declare PWAW-I64-int64! 111 | a/least-sig: FFFFFFFFh 112 | a/most-sig: 7FFFFFFFh 113 | b: declare PWAW-I64-int64! 114 | b/least-sig: 2 115 | b/most-sig: 0 116 | c: declare PWAW-I64-int64! 117 | --assert PWAW-I64-OVERFLOW = PWAW-I64-add a b c 118 | 119 | ~~~end-file~~~ 120 | 121 | -------------------------------------------------------------------------------- /LibTom/Tests/mp-div-2d-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "mp-div2d" 4 | 5 | --test-- "mpdiv2d1" 6 | mpdiv2d1-mp-int1: declare LTM-int! 7 | response: LTM-init mpdiv2d1-mp-int1 8 | --assert response = LTM-OKAY 9 | response: LTM-set-int mpdiv2d1-mp-int1 2 10 | --assert response = LTM-OKAY 11 | mpdiv2d1-mp-int2: declare LTM-int! 12 | response: LTM-init mpdiv2d1-mp-int2 13 | --assert response = LTM-OKAY 14 | mpdiv2d1-mp-int3: declare LTM-int! 15 | response: LTM-init mpdiv2d1-mp-int3 16 | --assert response = LTM-OKAY 17 | response: LTM-div-2d mpdiv2d1-mp-int1 1 mpdiv2d1-mp-int2 mpdiv2d1-mp-int3 18 | --assert response = LTM-OKAY 19 | --assert mpdiv2d1-mp-int2/mp-digit/value = (as LTM-digit! 1) 20 | --assert mpdiv2d1-mp-int2/used = 1 21 | --assert mpdiv2d1-mp-int2/sign = LTM-ZPOS 22 | --assert mpdiv2d1-mp-int3/mp-digit/value = (as LTM-digit! 0) 23 | --assert mpdiv2d1-mp-int3/sign = LTM-ZPOS 24 | --assert mpdiv2d1-mp-int3/used = 0 25 | 26 | --test-- "mpdiv2d2" 27 | mpdiv2d2-mp-int1: declare LTM-int! 28 | response: LTM-init mpdiv2d2-mp-int1 29 | --assert response = LTM-OKAY 30 | response: LTM-set-int mpdiv2d2-mp-int1 2 31 | --assert response = LTM-OKAY 32 | mpdiv2d2-mp-int2: declare LTM-int! 33 | response: LTM-init mpdiv2d2-mp-int2 34 | --assert response = LTM-OKAY 35 | mpdiv2d2-mp-int3: declare LTM-int! 36 | response: LTM-init mpdiv2d2-mp-int3 37 | --assert response = LTM-OKAY 38 | response: LTM-div-2d mpdiv2d2-mp-int1 2 mpdiv2d2-mp-int2 mpdiv2d2-mp-int3 39 | --assert response = LTM-OKAY 40 | --assert mpdiv2d2-mp-int2/mp-digit/value = (as LTM-digit! 0) 41 | --assert mpdiv2d2-mp-int2/used = 0 42 | --assert mpdiv2d2-mp-int2/sign = LTM-ZPOS 43 | --assert mpdiv2d2-mp-int3/mp-digit/value = (as LTM-digit! 2) 44 | --assert mpdiv2d2-mp-int3/sign = LTM-ZPOS 45 | --assert mpdiv2d2-mp-int3/used = 1 46 | 47 | --test-- "mpdiv2d3" 48 | mpdiv2d3-mp-int1: declare LTM-int! 49 | response: LTM-init mpdiv2d3-mp-int1 50 | --assert response = LTM-OKAY 51 | response: LTM-set-int mpdiv2d3-mp-int1 3 52 | --assert response = LTM-OKAY 53 | mpdiv2d3-mp-int2: declare LTM-int! 54 | response: LTM-init mpdiv2d3-mp-int2 55 | --assert response = LTM-OKAY 56 | mpdiv2d3-mp-int3: declare LTM-int! 57 | response: LTM-init mpdiv2d3-mp-int3 58 | --assert response = LTM-OKAY 59 | response: LTM-div-2d mpdiv2d3-mp-int1 1 mpdiv2d3-mp-int2 mpdiv2d3-mp-int3 60 | --assert response = LTM-OKAY 61 | --assert mpdiv2d3-mp-int2/mp-digit/value = (as LTM-digit! 1) 62 | --assert mpdiv2d3-mp-int2/used = 1 63 | --assert mpdiv2d3-mp-int2/sign = LTM-ZPOS 64 | --assert mpdiv2d3-mp-int3/mp-digit/value = (as LTM-digit! 1) 65 | --assert mpdiv2d3-mp-int3/sign = LTM-ZPOS 66 | --assert mpdiv2d3-mp-int3/used = 1 67 | 68 | --test-- "mpdiv2d4" 69 | mpdiv2d4-mp-int1: declare LTM-int! 70 | response: LTM-init mpdiv2d4-mp-int1 71 | --assert response = LTM-OKAY 72 | response: LTM-set-int mpdiv2d4-mp-int1 127 73 | --assert response = LTM-OKAY 74 | mpdiv2d4-mp-int2: declare LTM-int! 75 | response: LTM-init mpdiv2d4-mp-int2 76 | --assert response = LTM-OKAY 77 | mpdiv2d4-mp-int3: declare LTM-int! 78 | response: LTM-init mpdiv2d4-mp-int3 79 | --assert response = LTM-OKAY 80 | response: LTM-div-2d mpdiv2d4-mp-int1 6 mpdiv2d4-mp-int2 mpdiv2d4-mp-int3 81 | --assert response = LTM-OKAY 82 | --assert mpdiv2d4-mp-int2/mp-digit/value = (as LTM-digit! 1) 83 | --assert mpdiv2d4-mp-int2/used = 1 84 | --assert mpdiv2d4-mp-int2/sign = LTM-ZPOS 85 | --assert mpdiv2d4-mp-int3/mp-digit/value = (as LTM-digit! 63) 86 | --assert mpdiv2d4-mp-int3/sign = LTM-ZPOS 87 | --assert mpdiv2d4-mp-int3/used = 1 88 | 89 | ===end-group=== -------------------------------------------------------------------------------- /LibTom/Tests/mp-div-2-group.reds: -------------------------------------------------------------------------------- 1 | Red/System [] 2 | 3 | ===start-group=== "divide by 2" 4 | 5 | --test-- "mp-div-2-1" 6 | mp-div-2-1-int1: declare LTM-int! 7 | response: LTM-init mp-div-2-1-int1 8 | --assert response = LTM-OKAY 9 | mp-div-2-1-int2: declare LTM-int! 10 | response: LTM-init mp-div-2-1-int2 11 | --assert response = LTM-OKAY 12 | response: LTM-div-2 mp-div-2-1-int1 mp-div-2-1-int2 13 | --assert response = LTM-OKAY 14 | --assert mp-div-2-1-int2/used = 0 15 | --assert mp-div-2-1-int2/mp-digit/value = as LTM-digit! 0 16 | 17 | --test-- "mp-div-2-2" 18 | mp-div-2-2-int1: declare LTM-int! 19 | response: LTM-init mp-div-2-2-int1 20 | --assert response = LTM-OKAY 21 | mp-div-2-2-int1/mp-digit/value: as LTM-digit! 32 22 | mp-div-2-2-int1/used: 1 23 | mp-div-2-2-int2: declare LTM-int! 24 | response: LTM-init mp-div-2-2-int2 25 | --assert response = LTM-OKAY 26 | response: LTM-div-2 mp-div-2-2-int1 mp-div-2-2-int2 27 | --assert response = LTM-OKAY 28 | --assert mp-div-2-2-int2/used = 1 29 | mp-div-2-2-bp: mp-div-2-2-int2/mp-digit 30 | --assert mp-div-2-2-bp/value = as LTM-digit! 16 31 | 32 | --test-- "mp-div-2-3" 33 | mp-div-2-3-int1: declare LTM-int! 34 | response: LTM-init mp-div-2-3-int1 35 | --assert response = LTM-OKAY 36 | mp-div-2-3-bp: mp-div-2-3-int1/mp-digit 37 | mp-div-2-3-bp/value: as LTM-digit! 126 38 | mp-div-2-3-bp: mp-div-2-3-bp + 1 39 | mp-div-2-3-bp/value: as LTM-digit! 1 40 | mp-div-2-3-int1/used: 2 41 | mp-div-2-3-int2: declare LTM-int! 42 | response: LTM-init mp-div-2-3-int2 43 | --assert response = LTM-OKAY 44 | response: LTM-div-2 mp-div-2-3-int1 mp-div-2-3-int2 45 | --assert response = LTM-OKAY 46 | --assert mp-div-2-3-int2/used = 1 47 | --assert mp-div-2-3-int2/mp-digit/value = as LTM-digit! 127 48 | 49 | --test-- "mp-div-2-4" 50 | mp-div-2-4-int1: declare LTM-int! 51 | response: LTM-init mp-div-2-4-int1 52 | --assert response = LTM-OKAY 53 | mp-div-2-4-int1/mp-digit/value: as LTM-digit! 2 54 | mp-div-2-4-int1/used: 1 55 | mp-div-2-4-int1/sign: LTM-NEG 56 | mp-div-2-4-int2: declare LTM-int! 57 | response: LTM-init mp-div-2-4-int2 58 | --assert response = LTM-OKAY 59 | response: LTM-div-2 mp-div-2-4-int1 mp-div-2-4-int2 60 | --assert response = LTM-OKAY 61 | --assert mp-div-2-4-int2/used = 1 62 | --assert mp-div-2-4-int2/mp-digit/value = as LTM-digit! 1 63 | --assert mp-div-2-4-int2/sign = LTM-NEG 64 | 65 | --test-- "mp-div-2-5" 66 | mp-div-2-5-int1: declare LTM-int! 67 | response: LTM-init mp-div-2-5-int1 68 | mp-div-2-5-int1/used: 1 69 | mp-div-2-5-int1/mp-digit/1: as LTM-digit! 33 70 | --assert response = LTM-OKAY 71 | mp-div-2-5-int2: declare LTM-int! 72 | response: LTM-init mp-div-2-5-int2 73 | --assert response = LTM-OKAY 74 | response: LTM-div-2 mp-div-2-5-int1 mp-div-2-5-int2 75 | --assert response = LTM-OKAY 76 | --assert mp-div-2-5-int2/used = 1 77 | --assert mp-div-2-5-int2/mp-digit/1 = as LTM-digit! 16 78 | --assert mp-div-2-5-int2/sign = LTM-ZPOS 79 | 80 | --test-- "mp-div-2-6" 81 | mp-div-2-6-int1: declare LTM-int! 82 | response: LTM-init mp-div-2-6-int1 83 | --assert response = LTM-OKAY 84 | mp-div-2-6-int1/mp-digit/value: as LTM-digit! 127 85 | mp-div-2-6-int1/used: 1 86 | mp-div-2-6-int1/sign: LTM-NEG 87 | mp-div-2-6-int2: declare LTM-int! 88 | response: LTM-init mp-div-2-6-int2 89 | --assert response = LTM-OKAY 90 | response: LTM-div-2 mp-div-2-6-int1 mp-div-2-6-int2 91 | --assert response = LTM-OKAY 92 | --assert mp-div-2-6-int2/used = 1 93 | --assert mp-div-2-6-int2/sign = LTM-NEG 94 | --assert mp-div-2-6-int2/mp-digit/1 = as LTM-digit! 63 95 | 96 | ===end-group=== -------------------------------------------------------------------------------- /DateTime/Tests/days-in-year-todate-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System core library - days-in-year test script" 3 | Author: "Peter W A Wood" 4 | Rights: "Copyright (C) 2013 Peter W A Wood. All rights reserved." 5 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt" 6 | ] 7 | 8 | #include %../../quick-test.reds 9 | #include %../PWAW-DT-date-time.reds 10 | 11 | ~~~start-file~~~ "date-to-days" 12 | 13 | --test-- "diy-1" 14 | i: 0 15 | d: declare PWAW-DT-date! 16 | d/year: 0 17 | d/month: 1 18 | d/day: 1 19 | d/hour: 0 20 | d/minutes: 0 21 | d/seconds: 0 22 | d/microseconds: 0 23 | d/tz-hours: 0 24 | d/tz-minutes: 0 25 | --assert 0 = PWAW-DT-days-in-year-todate d :i 26 | --assert 0 = i 27 | 28 | --test-- "diy-2" 29 | i: 0 30 | d: declare PWAW-DT-date! 31 | d/year: 0 32 | d/month: 1 33 | d/day: 31 34 | d/hour: 0 35 | d/minutes: 0 36 | d/seconds: 0 37 | d/microseconds: 0 38 | d/tz-hours: 0 39 | d/tz-minutes: 0 40 | --assert 0 = PWAW-DT-days-in-year-todate d :i 41 | --assert 30 = i 42 | 43 | --test-- "diy-3" 44 | i: 0 45 | d: declare PWAW-DT-date! 46 | d/year: 0 47 | d/month: 2 48 | d/day: 1 49 | d/hour: 0 50 | d/minutes: 0 51 | d/seconds: 0 52 | d/microseconds: 0 53 | d/tz-hours: 0 54 | d/tz-minutes: 0 55 | --assert 0 = PWAW-DT-days-in-year-todate d :i 56 | --assert 31 = i 57 | 58 | --test-- "diy-4" 59 | i: 0 60 | d: declare PWAW-DT-date! 61 | d/year: 2000 62 | d/month: 3 63 | d/day: 1 64 | d/hour: 0 65 | d/minutes: 0 66 | d/seconds: 0 67 | d/microseconds: 0 68 | d/tz-hours: 0 69 | d/tz-minutes: 0 70 | --assert 0 = PWAW-DT-days-in-year-todate d :i 71 | --assert 60 = i 72 | 73 | --test-- "diy-5" 74 | i: 0 75 | d: declare PWAW-DT-date! 76 | d/year: 1996 77 | d/month: 3 78 | d/day: 1 79 | d/hour: 0 80 | d/minutes: 0 81 | d/seconds: 0 82 | d/microseconds: 0 83 | d/tz-hours: 0 84 | d/tz-minutes: 0 85 | --assert 0 = PWAW-DT-days-in-year-todate d :i 86 | --assert 60 = i 87 | 88 | --test-- "diy-5" 89 | i: 0 90 | d: declare PWAW-DT-date! 91 | d/year: 1900 92 | d/month: 3 93 | d/day: 1 94 | d/hour: 0 95 | d/minutes: 0 96 | d/seconds: 0 97 | d/microseconds: 0 98 | d/tz-hours: 0 99 | d/tz-minutes: 0 100 | --assert 0 = PWAW-DT-days-in-year-todate d :i 101 | --assert 59 = i 102 | 103 | --test-- "diy-6" 104 | i: 0 105 | d: declare PWAW-DT-date! 106 | d/year: 2014 107 | d/month: 12 108 | d/day: 15 109 | d/hour: 0 110 | d/minutes: 0 111 | d/seconds: 0 112 | d/microseconds: 0 113 | d/tz-hours: 0 114 | d/tz-minutes: 0 115 | --assert 0 = PWAW-DT-days-in-year-todate d :i 116 | --assert 348 = i 117 | 118 | ~~~end-file~~~ 119 | 120 | --------------------------------------------------------------------------------