pcc/runtime/purescript.cc · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on 8698eaa help sign in

rowtype-yoga/purescript-native/pcc/runtime/purescript.cc

291 lines 10 kB history raw

1///////////////////////////////////////////////////////////////////////////////

2//

3// Module : purescript.cc

4// Copyright : (c) Andy Arvanitis 2015

5// License : MIT

6//

7// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>

8// Stability : experimental

9// Portability :

10//

11// Basic types and functions to support purescript-to-C++1x rendering

12//

13///////////////////////////////////////////////////////////////////////////////

14//

15#include <cstring>

16#include "PureScript.hh"

18namespace PureScript {

20any::closure::~closure() {}

21any::eff_closure::~eff_closure() {}

23#define RETURN_VALUE(TAG, ACCESSOR, INDIRECTION) \

24 const any& variant = unthunkVariant(*this); \

25 assert(variant.tag == TAG); \

26 return INDIRECTION(variant.ACCESSOR); \

28auto any::operator()(const any& arg) const -> any {

29 const any& variant = unthunkVariant(*this);

30 if (variant.tag == tag_t::Closure) {

31 return (*variant.l)(arg);

32 }

33 assert(variant.tag == tag_t::Function);

34 return (*variant.f)(arg);

35}

37auto any::operator()(const as_thunk) const -> const any& {

38 assert(tag == tag_t::Thunk);

39 return (*t)(unthunk);

40}

42auto any::operator()() const -> any {

43 const any& variant = unthunkVariant(*this);

44 if (variant.tag == tag_t::EffClosure) {

45 return (*variant.k)();

46 }

47 assert(variant.tag == tag_t::EffFunction);

48 return (*variant.e)();

49}

51any::operator int() const {

52 RETURN_VALUE(tag_t::Integer, i,)

53}

55any::operator double() const {

56 RETURN_VALUE(tag_t::Double, d,)

57}

59any::operator bool() const {

60 RETURN_VALUE(tag_t::Boolean, b,)

61}

63any::operator char() const {

64 RETURN_VALUE(tag_t::Character, c,)

65}

67any::operator cstring() const {

68 const any& variant = unthunkVariant(*this);

69 if (variant.tag == tag_t::StringLiteral) {

70 return variant.r;

71 }

72 assert(variant.tag == tag_t::String);

73 return variant.s->c_str();

74}

76any::operator const array&() const {

77 RETURN_VALUE(tag_t::Array, a, *)

78}

80auto any::extractPointer(IF_DEBUG(const any::tag_t t)) const -> void* {

81 RETURN_VALUE(t, POINTER_FROM_MEMBER(p),)

82}

84auto any::unthunkVariant(const any& a) -> const any& {

85 const any * variant = &a;

86 while (variant->tag == tag_t::Thunk) {

87 variant = &((*variant->t)(unthunk));

88 }

89 return *variant;

90}

92auto any::operator[](const symbol_t key) const -> const any& {

93 return PureScript::map::get(key, cast<map<unknown_size>>(*this));

94}

96auto any::operator[](const size_t rhs) const -> const any& {

97 const auto& xs = cast<array>(*this);

98 return xs[rhs];

99}

100

101auto any::operator[](const any& rhs) const -> const any& {

102 const auto& xs = cast<array>(*this);

103 return xs[cast<int>(rhs)];

104}

105

106auto any::size() const -> size_t {

107 return cast<array>(*this).size();

108}

109

110auto any::empty() const -> bool {

111 return cast<array>(*this).empty();

112}

113

114auto any::contains(const symbol_t key) const -> bool {

115 // TODO: assumes at least one element -- safe assumption?

116 const auto& m = cast<map<unknown_size>>(*this);

117 std::remove_reference<decltype(m)>::type::size_type i = 0;

118 do {

119 if (m[i].first == key) {

120 return true;

121 }

122 } while (m[++i].first != nullptr);

123 return false;

124}

125

126//-----------------------------------------------------------------------------

127// Operator helper macros

128//-----------------------------------------------------------------------------

129

130#define DEFINE_CSTR_EQUALS_OPERATOR() \

131 auto operator==(const any& lhs_, const char * rhs) -> bool { \

132 const any& lhs = any::unthunkVariant(lhs_); \

133 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String); \

134 if (lhs.tag == any::tag_t::StringLiteral) { \

135 return (lhs.r == rhs) || (strcmp(lhs.r, rhs) == 0); \

136 } \

137 return strcmp(lhs.s->c_str(), rhs) == 0; \

138 } \

139 auto operator==(const char * lhs, const any& rhs_) -> bool { \

140 const any& rhs = any::unthunkVariant(rhs_); \

141 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String); \

142 if (rhs.tag == any::tag_t::StringLiteral) { \

143 return (lhs == rhs.r) || (strcmp(lhs, rhs) == 0); \

144 } \

145 return strcmp(lhs, rhs.s->c_str()) == 0; \

146 }

147

148#define DEFINE_CSTR_COMPARISON_OPERATOR(op) \

149 auto operator op (const any& lhs, const char * rhs) -> bool { \

150 return strcmp(cast<cstring>(lhs), rhs) op 0; \

151 } \

152 auto operator op (const char * lhs, const any& rhs) -> bool { \

153 return strcmp(lhs, cast<cstring>(rhs)) op 0; \

154 }

155

156#define DEFINE_COMPARISON_OPERATOR(op) \

157 auto operator op (const any& lhs_, const any& rhs_) -> bool { \

158 const any& lhs = any::unthunkVariant(lhs_); \

159 const any& rhs = any::unthunkVariant(rhs_); \

160 switch (lhs.tag) { \

161 case any::tag_t::Integer: assert(lhs.tag == any::tag_t::Integer); return lhs.i op rhs.i; \

162 case any::tag_t::Double: assert(lhs.tag == any::tag_t::Double); return lhs.d op rhs.d; \

163 case any::tag_t::Character: assert(lhs.tag == any::tag_t::Character); return lhs.c op rhs.c; \

164 case any::tag_t::Boolean: assert(lhs.tag == any::tag_t::Boolean); return lhs.b op rhs.b; \

165 case any::tag_t::StringLiteral: \

166 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String); \

167 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String); \

168 return strcmp(lhs.r, rhs.tag == any::tag_t::StringLiteral ? rhs.r : rhs.s->c_str()) op 0; \

169 case any::tag_t::String: \

170 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String); \

171 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String); \

172 return strcmp(lhs.s->c_str(), rhs.tag == any::tag_t::StringLiteral ? rhs.r : rhs.s->c_str()) op 0; \

173 case any::tag_t::Pointer: return lhs.p op rhs.p; \

174 default: assert(false && "Unsupported tag for operator " #op); \

175 } \

176 return false; \

177 }

178

179//-----------------------------------------------------------------------------

180// Operator definitions

181//-----------------------------------------------------------------------------

182

183DEFINE_COMPARISON_OPERATOR(==)

184DEFINE_COMPARISON_OPERATOR(!=)

185DEFINE_COMPARISON_OPERATOR(<)

186DEFINE_COMPARISON_OPERATOR(<=)

187DEFINE_COMPARISON_OPERATOR(>)

188DEFINE_COMPARISON_OPERATOR(>=)

189

190DEFINE_CSTR_EQUALS_OPERATOR()

191DEFINE_CSTR_COMPARISON_OPERATOR(!=)

192DEFINE_CSTR_COMPARISON_OPERATOR(<)

193DEFINE_CSTR_COMPARISON_OPERATOR(<=)

194DEFINE_CSTR_COMPARISON_OPERATOR(>)

195DEFINE_CSTR_COMPARISON_OPERATOR(>=)

196

197auto operator+(const any& lhs_, const any& rhs_) -> any {

198 const any& lhs = any::unthunkVariant(lhs_);

199 const any& rhs = any::unthunkVariant(rhs_);

200 switch (lhs.tag) {

201 case any::tag_t::Integer: assert(lhs.tag == any::tag_t::Integer); return lhs.i + rhs.i;

202 case any::tag_t::Double: assert(lhs.tag == any::tag_t::Double); return lhs.d + rhs.d;

203 case any::tag_t::Character: assert(lhs.tag == any::tag_t::Character); return any(char(lhs.c + rhs.c));

204 case any::tag_t::StringLiteral:

205 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String);

206 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String);

207 return rhs.tag == any::tag_t::StringLiteral ? std::string(lhs.r) + rhs.r : lhs.r + *rhs.s;

208 case any::tag_t::String:

209 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String);

210 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String);

211 return rhs.tag == any::tag_t::StringLiteral ? *lhs.s + rhs.r : *lhs.s + *rhs.s;

212 default: assert(false && "Unsupported tag for '+' operator");

213 }

214 return nullptr;

215}

216

217auto operator+(const any& lhs_, const char * rhs) -> std::string {

218 const any& lhs = any::unthunkVariant(lhs_);

219 assert(lhs.tag == any::tag_t::StringLiteral || lhs.tag == any::tag_t::String);

220 return lhs.tag == any::tag_t::StringLiteral ? std::string(lhs.r) + rhs : *lhs.s + rhs;

221}

222

223auto operator+(const char * lhs, const any& rhs_) -> std::string {

224 const any& rhs = any::unthunkVariant(rhs_);

225 assert(rhs.tag == any::tag_t::StringLiteral || rhs.tag == any::tag_t::String);

226 return rhs.tag == any::tag_t::StringLiteral ? lhs + std::string(rhs.r) : lhs + *rhs.s;

227}

228

229auto operator-(const any& lhs_, const any& rhs_) -> any {

230 const any& lhs = any::unthunkVariant(lhs_);

231 const any& rhs = any::unthunkVariant(rhs_);

232 assert(lhs.tag == rhs.tag);

233 switch (lhs.tag) {

234 case any::tag_t::Integer: return lhs.i - rhs.i;

235 case any::tag_t::Double: return lhs.d - rhs.d;

236 case any::tag_t::Character: return any(char(lhs.c - rhs.c));

237 default: assert(false && "Unsupported tag for '-' operator");

238 }

239 return nullptr;

240}

241

242auto operator*(const any& lhs_, const any& rhs_) -> any {

243 const any& lhs = any::unthunkVariant(lhs_);

244 const any& rhs = any::unthunkVariant(rhs_);

245 assert(lhs.tag == rhs.tag);

246 switch (lhs.tag) {

247 case any::tag_t::Integer: return lhs.i * rhs.i;

248 case any::tag_t::Double: return lhs.d * rhs.d;

249 case any::tag_t::Character: return any(char(lhs.c * rhs.c));

250 default: assert(false && "Unsupported tag for '*' operator");

251 }

252 return nullptr;

253}

254

255auto operator/(const any& lhs_, const any& rhs_) -> any {

256 const any& lhs = any::unthunkVariant(lhs_);

257 const any& rhs = any::unthunkVariant(rhs_);

258 assert(lhs.tag == rhs.tag);

259 switch (lhs.tag) {

260 case any::tag_t::Integer: return lhs.i / rhs.i;

261 case any::tag_t::Double: return lhs.d / rhs.d;

262 case any::tag_t::Character: return any(char(lhs.c / rhs.c));

263 default: assert(false && "Unsupported tag for '/' operator");

264 }

265 return nullptr;

266}

267

268auto operator%(const any& lhs_, const any& rhs_) -> any {

269 const any& lhs = any::unthunkVariant(lhs_);

270 const any& rhs = any::unthunkVariant(rhs_);

271 assert(lhs.tag == rhs.tag);

272 switch (lhs.tag) {

273 case any::tag_t::Integer: return lhs.i % rhs.i;

274 case any::tag_t::Character: return any(char(lhs.c % rhs.c));

275 default: assert(false && "Unsupported tag for '%' operator");

276 }

277 return nullptr;

278}

279

280// unary negate

281auto operator-(const any& rhs_) -> any {

282 const any& rhs = any::unthunkVariant(rhs_);

283 switch (rhs.tag) {

284 case any::tag_t::Integer: return (- rhs.i);

285 case any::tag_t::Double: return (- rhs.d);

286 default: assert(false && "Unsupported tag for unary '-' operator");

287 }

288 return nullptr;

289}

290

291} // namespace PureScript