1. # the uses of add_I in this class are a trick to make bigints work right
  2. my class IntStr is Int is Str {
  3. method new(Int $i, Str $s) {
  4. my \SELF = nqp::add_I($i, 0, self);
  5. nqp::bindattr_s(SELF, Str, '$!value', $s);
  6. SELF;
  7. }
  8. multi method Numeric(IntStr:D:) { self.Int }
  9. method Int(IntStr:D:) { nqp::add_I(self, 0, Int) }
  10. multi method Str(IntStr:D:) { nqp::getattr_s(self, Str, '$!value') }
  11. multi method perl(IntStr:D:) { self.^name ~ '.new(' ~ self.Int.perl ~ ', ' ~ self.Str.perl ~ ')' }
  12. }
  13. my class NumStr is Num is Str {
  14. method new(Num $n, Str $s) {
  15. my \SELF = nqp::create(self);
  16. nqp::bindattr_n(SELF, Num, '$!value', $n);
  17. nqp::bindattr_s(SELF, Str, '$!value', $s);
  18. SELF;
  19. }
  20. multi method Numeric(NumStr:D:) { self.Num }
  21. method Num(NumStr:D:) { nqp::getattr_n(self, Num, '$!value') }
  22. multi method Str(NumStr:D:) { nqp::getattr_s(self, Str, '$!value') }
  23. multi method perl(NumStr:D:) { self.^name ~ '.new(' ~ self.Num.perl ~ ', ' ~ self.Str.perl ~ ')' }
  24. }
  25. my class RatStr is Rat is Str {
  26. method new(Rat $r, Str $s) {
  27. my \SELF = nqp::create(self);
  28. nqp::bindattr(SELF, Rat, '$!numerator', $r.numerator);
  29. nqp::bindattr(SELF, Rat, '$!denominator', $r.denominator);
  30. nqp::bindattr_s(SELF, Str, '$!value', $s);
  31. SELF;
  32. }
  33. multi method Numeric(RatStr:D:) { self.Rat }
  34. method Rat(RatStr:D:) { Rat.new(nqp::getattr(self, Rat, '$!numerator'), nqp::getattr(self, Rat, '$!denominator')) }
  35. multi method Str(RatStr:D:) { nqp::getattr_s(self, Str, '$!value') }
  36. multi method perl(RatStr:D:) { self.^name ~ '.new(' ~ self.Rat.perl ~ ', ' ~ self.Str.perl ~ ')' }
  37. }
  38. my class ComplexStr is Complex is Str {
  39. method new(Complex $c, Str $s) {
  40. my \SELF = nqp::create(self);
  41. nqp::bindattr_n(SELF, Complex, '$!re', $c.re);
  42. nqp::bindattr_n(SELF, Complex, '$!im', $c.im);
  43. nqp::bindattr_s(SELF, Str, '$!value', $s);
  44. SELF;
  45. }
  46. multi method Numeric(ComplexStr:D:) { self.Complex }
  47. method Complex(ComplexStr:D:) { Complex.new(nqp::getattr_n(self, Complex, '$!re'), nqp::getattr_n(self, Complex, '$!im')) }
  48. multi method Str(ComplexStr:D:) { nqp::getattr_s(self, Str, '$!value') }
  49. multi method perl(ComplexStr:D:) { self.^name ~ '.new(' ~ self.Complex.perl ~ ', ' ~ self.Str.perl ~ ')' }
  50. }
  51. # we define cmp ops for these allomorphic types as numeric first, then Str. If
  52. # you want just one half of the cmp, you'll need to coerce the args
  53. multi sub infix:<cmp>(IntStr:D $a, IntStr:D $b) { $a.Int cmp $b.Int || $a.Str cmp $b.Str }
  54. multi sub infix:<cmp>(IntStr:D $a, RatStr:D $b) { $a.Int cmp $b.Rat || $a.Str cmp $b.Str }
  55. multi sub infix:<cmp>(IntStr:D $a, NumStr:D $b) { $a.Int cmp $b.Num || $a.Str cmp $b.Str }
  56. multi sub infix:<cmp>(IntStr:D $a, ComplexStr:D $b) { $a.Int cmp $b.Complex || $a.Str cmp $b.Str }
  57. multi sub infix:<cmp>(RatStr:D $a, IntStr:D $b) { $a.Rat cmp $b.Int || $a.Str cmp $b.Str }
  58. multi sub infix:<cmp>(RatStr:D $a, RatStr:D $b) { $a.Rat cmp $b.Rat || $a.Str cmp $b.Str }
  59. multi sub infix:<cmp>(RatStr:D $a, NumStr:D $b) { $a.Rat cmp $b.Num || $a.Str cmp $b.Str }
  60. multi sub infix:<cmp>(RatStr:D $a, ComplexStr:D $b) { $a.Rat cmp $b.Complex || $a.Str cmp $b.Str }
  61. multi sub infix:<cmp>(NumStr:D $a, IntStr:D $b) { $a.Num cmp $b.Int || $a.Str cmp $b.Str }
  62. multi sub infix:<cmp>(NumStr:D $a, RatStr:D $b) { $a.Num cmp $b.Rat || $a.Str cmp $b.Str }
  63. multi sub infix:<cmp>(NumStr:D $a, NumStr:D $b) { $a.Num cmp $b.Num || $a.Str cmp $b.Str }
  64. multi sub infix:<cmp>(NumStr:D $a, ComplexStr:D $b) { $a.Num cmp $b.Complex || $a.Str cmp $b.Str }
  65. multi sub infix:<cmp>(ComplexStr:D $a, IntStr:D $b) { $a.Complex cmp $b.Int || $a.Str cmp $b.Str }
  66. multi sub infix:<cmp>(ComplexStr:D $a, RatStr:D $b) { $a.Complex cmp $b.Rat || $a.Str cmp $b.Str }
  67. multi sub infix:<cmp>(ComplexStr:D $a, NumStr:D $b) { $a.Complex cmp $b.Num || $a.Str cmp $b.Str }
  68. multi sub infix:<cmp>(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex cmp $b.Complex || $a.Str cmp $b.Str }
  69. multi sub infix:<eqv>(IntStr:D $a, IntStr:D $b) { $a.Int eqv $b.Int && $a.Str eqv $b.Str }
  70. multi sub infix:<eqv>(IntStr:D $a, RatStr:D $b --> False) {}
  71. multi sub infix:<eqv>(IntStr:D $a, NumStr:D $b --> False) {}
  72. multi sub infix:<eqv>(IntStr:D $a, ComplexStr:D $b --> False) {}
  73. multi sub infix:<eqv>(RatStr:D $a, IntStr:D $b --> False) {}
  74. multi sub infix:<eqv>(RatStr:D $a, RatStr:D $b) { $a.Rat eqv $b.Rat && $a.Str eqv $b.Str }
  75. multi sub infix:<eqv>(RatStr:D $a, NumStr:D $b --> False) {}
  76. multi sub infix:<eqv>(RatStr:D $a, ComplexStr:D $b --> False) {}
  77. multi sub infix:<eqv>(NumStr:D $a, IntStr:D $b --> False) {}
  78. multi sub infix:<eqv>(NumStr:D $a, RatStr:D $b --> False) {}
  79. multi sub infix:<eqv>(NumStr:D $a, NumStr:D $b) { $a.Num eqv $b.Num && $a.Str eqv $b.Str }
  80. multi sub infix:<eqv>(NumStr:D $a, ComplexStr:D $b --> False) {}
  81. multi sub infix:<eqv>(ComplexStr:D $a, IntStr:D $b --> False) {}
  82. multi sub infix:<eqv>(ComplexStr:D $a, RatStr:D $b --> False) {}
  83. multi sub infix:<eqv>(ComplexStr:D $a, NumStr:D $b --> False) {}
  84. multi sub infix:<eqv>(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex eqv $b.Complex && $a.Str eqv $b.Str }
  85. multi sub infix:<===>(IntStr:D $a, IntStr:D $b) {
  86. $a.Int === $b.Int && $a.Str === $b.Str
  87. }
  88. multi sub infix:<===>(RatStr:D $a, RatStr:D $b) {
  89. $a.Rat === $b.Rat && $a.Str === $b.Str
  90. }
  91. multi sub infix:<===>(NumStr:D $a, NumStr:D $b) {
  92. $a.Num === $b.Num && $a.Str === $b.Str
  93. }
  94. multi sub infix:<===>(ComplexStr:D $a, ComplexStr:D $b) {
  95. $a.Complex === $b.Complex && $a.Str === $b.Str
  96. }
  97. multi sub val(*@maybevals) {
  98. @maybevals.list.map({ val($_) }).eager;
  99. }
  100. multi sub val(Mu) {
  101. warn "Value of type Mu uselessly passed to val()";
  102. Mu
  103. }
  104. # needed to preserve slip-ness
  105. multi sub val(Slip:D $maybevals) {
  106. val(|$maybevals).Slip
  107. }
  108. multi sub val(Pair:D \ww-thing) is raw {
  109. # this is a Pair object possible in «» constructs; just pass it through. We
  110. # capture this specially from the below sub to avoid emitting a warning
  111. # whenever an affected «» construct is being processed.
  112. ww-thing
  113. }
  114. multi sub val(\one-thing) {
  115. warn "Value of type {one-thing.WHAT.perl} uselessly passed to val()";
  116. one-thing;
  117. }
  118. multi sub val(Str:D $MAYBEVAL, :$val-or-fail) {
  119. # TODO:
  120. # * Additional numeric styles:
  121. # + fractions in [] radix notation: :100[10,'.',53]
  122. # * Performance tuning
  123. # * Fix remaining XXXX
  124. my str $str = nqp::unbox_s($MAYBEVAL);
  125. my int $eos = nqp::chars($str);
  126. return IntStr.new(0,"") unless $eos; # handle ""
  127. # S02:3276-3277: Ignore leading and trailing whitespace
  128. my int $pos = nqp::findnotcclass(nqp::const::CCLASS_WHITESPACE,
  129. $str, 0, $eos);
  130. my int $end = nqp::sub_i($eos, 1);
  131. $end = nqp::sub_i($end, 1)
  132. while nqp::isge_i($end, $pos)
  133. && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $end);
  134. # Fail all the way out when parse failures occur. Return the original
  135. # string, or a failure if we're Str.Numeric
  136. my &parse_fail := -> \msg {
  137. $val-or-fail
  138. ?? fail X::Str::Numeric.new(:source($MAYBEVAL),:reason(msg),:$pos)
  139. !! return $MAYBEVAL
  140. }
  141. # Str.Numeric should handle blank string before val()
  142. parse_fail "Empty string not properly caught before val()" if nqp::islt_i($end, $pos);
  143. # Reset end-of-string after trimming
  144. $eos = nqp::add_i($end, 1);
  145. # return an appropriate type when we've found a number. Allomorphic unless
  146. # Str.Numeric is calling
  147. my &parse_win := -> \newval {
  148. $val-or-fail
  149. ?? return newval
  150. !! nqp::istype(newval, Num)
  151. ?? return NumStr.new(newval, $MAYBEVAL)
  152. !! nqp::istype(newval, Rat)
  153. ?? return RatStr.new(newval, $MAYBEVAL)
  154. !! nqp::istype(newval, Complex)
  155. ?? return ComplexStr.new(newval, $MAYBEVAL)
  156. !! nqp::istype(newval, Int)
  157. ?? return IntStr.new(newval, $MAYBEVAL)
  158. !! die "Unknown type {newval.^name} found in val() processing"
  159. }
  160. my sub parse-simple-number() {
  161. # Handle NaN here, to make later parsing simpler
  162. if nqp::eqat($str,'NaN',$pos) {
  163. $pos = nqp::add_i($pos, 3);
  164. return nqp::p6box_n(nqp::nan());
  165. }
  166. # Handle any leading +/-/− sign
  167. my int $ch = nqp::ord($str, $pos);
  168. my int $neg = nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722); # '-', '−'
  169. if $neg || nqp::iseq_i($ch, 43) { # '-', '−', '+'
  170. $pos = nqp::add_i($pos, 1);
  171. $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos);
  172. }
  173. # nqp::radix_I parse results, and helper values
  174. my Mu $parse;
  175. my str $prefix;
  176. my int $radix;
  177. my int $p;
  178. my sub parse-int-frac-exp() {
  179. # Integer part, if any
  180. my Int $int := 0;
  181. if nqp::isne_i($ch, 46) { # '.'
  182. parse_fail "Cannot convert radix of $radix (max 36)"
  183. if nqp::isgt_i($radix, 36);
  184. $parse := nqp::radix_I($radix, $str, $pos, $neg, Int);
  185. $p = nqp::atpos($parse, 2);
  186. parse_fail "base-$radix number must begin with valid digits or '.'"
  187. if nqp::iseq_i($p, -1);
  188. $pos = $p;
  189. $int := nqp::atpos($parse, 0);
  190. nqp::isge_i($pos, $eos)
  191. ?? return $int
  192. !! ($ch = nqp::ord($str, $pos));
  193. }
  194. # Fraction, if any
  195. my Int $frac := 0;
  196. my Int $base := 0;
  197. if nqp::iseq_i($ch, 46) { # '.'
  198. $pos = nqp::add_i($pos, 1);
  199. $parse := nqp::radix_I($radix, $str, $pos,
  200. nqp::add_i($neg, 4), Int);
  201. $p = nqp::atpos($parse, 2);
  202. parse_fail 'radix point must be followed by one or more valid digits'
  203. if nqp::iseq_i($p, -1);
  204. $pos = $p;
  205. $frac := nqp::atpos($parse, 0);
  206. $base := nqp::atpos($parse, 1);
  207. $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos);
  208. }
  209. # Exponent, if 'E' or 'e' are present (forces return type Num)
  210. if nqp::iseq_i($ch, 69) || nqp::iseq_i($ch, 101) { # 'E', 'e'
  211. parse_fail "'E' or 'e' style exponent only allowed on decimal (base-10) numbers, not base-$radix"
  212. unless nqp::iseq_i($radix, 10);
  213. $pos = nqp::add_i($pos, 1);
  214. # handle the sign
  215. # XXX TODO: teach radix_I to handle '−' (U+2212) minus?
  216. my int $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos);
  217. my int $neg-e = nqp::if(
  218. nqp::iseq_i($ch, 43), # '+'
  219. nqp::stmts(($pos = nqp::add_i($pos, 1)), 0),
  220. nqp::if( # '-', '−'
  221. nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722),
  222. nqp::stmts(($pos = nqp::add_i($pos, 1)), 1),
  223. 0,
  224. )
  225. );
  226. $parse := nqp::radix_I(10, $str, $pos, $neg-e, Int);
  227. $p = nqp::atpos($parse, 2);
  228. parse_fail "'E' or 'e' must be followed by decimal (base-10) integer"
  229. if nqp::iseq_i($p, -1);
  230. $pos = $p;
  231. return nqp::p6box_n(nqp::mul_n(
  232. $frac ?? nqp::add_n( $int.Num, nqp::div_n($frac.Num, $base.Num) )
  233. !! $int.Num,
  234. nqp::pow_n(10e0, nqp::atpos($parse, 0).Num)
  235. )) # if we have a zero, handle the sign correctly
  236. || nqp::if(nqp::iseq_i($neg, 1), -0e0, 0e0);
  237. }
  238. # Multiplier with exponent, if single '*' is present
  239. # (but skip if current token is '**', as otherwise we
  240. # get recursive multiplier parsing stupidity)
  241. if nqp::iseq_i($ch, 42)
  242. && nqp::isne_s(substr($str, $pos, 2), '**') { # '*'
  243. $pos = nqp::add_i($pos, 1);
  244. my $mult_base := parse-simple-number();
  245. parse_fail "'*' multiplier base must be an integer"
  246. unless nqp::istype($mult_base, Int);
  247. parse_fail "'*' multiplier base must be followed by '**' and exponent"
  248. unless nqp::eqat($str,'**',$pos);
  249. $pos = nqp::add_i($pos, 2);
  250. my $mult_exp := parse-simple-number();
  251. parse_fail "'**' multiplier exponent must be an integer"
  252. unless nqp::istype($mult_exp, Int);
  253. my $mult := $mult_base ** $mult_exp;
  254. $int := $int * $mult;
  255. $frac := $frac * $mult;
  256. }
  257. # Return an Int if there was no radix point, otherwise, return a Rat
  258. nqp::unless($base, $int, Rat.new($int * $base + $frac, $base));
  259. }
  260. # Look for radix specifiers
  261. if nqp::iseq_i($ch, 58) { # ':'
  262. # A string of the form :16<FE_ED.F0_0D> or :60[12,34,56]
  263. $pos = nqp::add_i($pos, 1);
  264. $parse := nqp::radix_I(10, $str, $pos, 0, Int);
  265. $p = nqp::atpos($parse, 2);
  266. parse_fail "radix (in decimal) expected after ':'"
  267. if nqp::iseq_i($p, -1);
  268. $pos = $p;
  269. $radix = nqp::atpos($parse, 0);
  270. $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos);
  271. if nqp::iseq_i($ch, 60) { # '<'
  272. $pos = nqp::add_i($pos, 1);
  273. my $result := parse-int-frac-exp();
  274. parse_fail "malformed ':$radix<>' style radix number, expecting '>' after the body"
  275. unless nqp::islt_i($pos, $eos)
  276. && nqp::iseq_i(nqp::ord($str, $pos), 62); # '>'
  277. $pos = nqp::add_i($pos, 1);
  278. return $result;
  279. }
  280. elsif nqp::iseq_i($ch, 171) { # '«'
  281. $pos = nqp::add_i($pos, 1);
  282. my $result := parse-int-frac-exp();
  283. parse_fail "malformed ':$radix«»' style radix number, expecting '»' after the body"
  284. unless nqp::islt_i($pos, $eos)
  285. && nqp::iseq_i(nqp::ord($str, $pos), 187); # '»'
  286. $pos = nqp::add_i($pos, 1);
  287. return $result;
  288. }
  289. elsif nqp::iseq_i($ch, 91) { # '['
  290. $pos = nqp::add_i($pos, 1);
  291. my Int $result := 0;
  292. my Int $digit := 0;
  293. while nqp::islt_i($pos, $eos)
  294. && nqp::isne_i(nqp::ord($str, $pos), 93) { # ']'
  295. $parse := nqp::radix_I(10, $str, $pos, 0, Int);
  296. $p = nqp::atpos($parse, 2);
  297. parse_fail "malformed ':$radix[]' style radix number, expecting comma separated decimal values after opening '['"
  298. if nqp::iseq_i($p, -1);
  299. $pos = $p;
  300. $digit := nqp::atpos($parse, 0);
  301. parse_fail "digit is larger than {$radix - 1} in ':$radix[]' style radix number"
  302. if nqp::isge_i($digit, $radix);
  303. $result := $result * $radix + $digit;
  304. $pos = nqp::add_i($pos, 1)
  305. if nqp::islt_i($pos, $eos)
  306. && nqp::iseq_i(nqp::ord($str, $pos), 44); # ','
  307. }
  308. parse_fail "malformed ':$radix[]' style radix number, expecting ']' after the body"
  309. unless nqp::islt_i($pos, $eos)
  310. && nqp::iseq_i(nqp::ord($str, $pos), 93); # ']'
  311. $pos = nqp::add_i($pos, 1);
  312. # XXXX: Handle fractions!
  313. # XXXX: Handle exponents!
  314. return $neg ?? -$result !! $result;
  315. }
  316. else {
  317. parse_fail "malformed ':$radix' style radix number, expecting '<' or '[' after the base";
  318. }
  319. }
  320. elsif nqp::iseq_i($ch, 48) # '0'
  321. and $radix = nqp::index(' b o d x',
  322. nqp::substr($str, nqp::add_i($pos, 1), 1))
  323. and nqp::isge_i($radix, 2) {
  324. # A string starting with 0x, 0d, 0o, or 0b,
  325. # followed by one optional '_'
  326. $pos = nqp::add_i($pos, 2);
  327. $pos = nqp::add_i($pos, 1)
  328. if nqp::islt_i($pos, $eos)
  329. && nqp::iseq_i(nqp::ord($str, $pos), 95); # '_'
  330. parse-int-frac-exp();
  331. }
  332. elsif nqp::eqat($str,'Inf',$pos) {
  333. # 'Inf'
  334. $pos = nqp::add_i($pos, 3);
  335. $neg ?? -Inf !! Inf;
  336. }
  337. else {
  338. # Last chance: a simple decimal number
  339. $radix = 10;
  340. parse-int-frac-exp();
  341. }
  342. }
  343. my sub parse-real() {
  344. # Parse a simple number or a Rat numerator
  345. my $result := parse-simple-number();
  346. return $result if nqp::iseq_i($pos, $eos);
  347. # Check for '/' indicating Rat denominator
  348. if nqp::iseq_i(nqp::ord($str, $pos), 47) { # '/'
  349. $pos = nqp::add_i($pos, 1);
  350. parse_fail "denominator expected after '/'"
  351. unless nqp::islt_i($pos, $eos);
  352. my $denom := parse-simple-number();
  353. $result := nqp::istype($result, Int) && nqp::istype($denom, Int)
  354. ?? Rat.new($result, $denom)
  355. !! $result / $denom;
  356. }
  357. $result;
  358. }
  359. # Parse a real number, magnitude of a pure imaginary number,
  360. # or real part of a complex number
  361. my $result := parse-real();
  362. parse_win $result if nqp::iseq_i($pos, $eos);
  363. # Check for 'i' or '\\i' indicating first parsed number was
  364. # the magnitude of a pure imaginary number
  365. if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i'
  366. parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i"
  367. if nqp::isnanorinf($result.Num);
  368. $pos = nqp::add_i($pos, 1);
  369. $result := Complex.new(0, $result);
  370. }
  371. elsif nqp::eqat($str,'\\i',$pos) {
  372. $pos = nqp::add_i($pos, 2);
  373. $result := Complex.new(0, $result);
  374. }
  375. # Check for '+' or '-' indicating first parsed number was
  376. # the real part of a complex number
  377. elsif nqp::iseq_i(nqp::ord($str, $pos), 45) # '-'
  378. || nqp::iseq_i(nqp::ord($str, $pos), 43) # '+'
  379. || nqp::iseq_i(nqp::ord($str, $pos), 8722) { # '−'
  380. # Don't move $pos -- we want parse-real() to see the sign
  381. my $im := parse-real();
  382. parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'"
  383. unless nqp::islt_i($pos, $eos);
  384. if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i'
  385. parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i"
  386. if nqp::isnanorinf($im.Num);
  387. $pos = nqp::add_i($pos, 1);
  388. }
  389. elsif nqp::eqat($str,'\\i',$pos) {
  390. $pos = nqp::add_i($pos, 2);
  391. }
  392. else {
  393. parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'"
  394. }
  395. $result := Complex.new($result, $im);
  396. }
  397. # Check for trailing garbage
  398. parse_fail "trailing characters after number"
  399. if nqp::islt_i($pos, $eos);
  400. parse_win $result;
  401. }