1# Do not edit this file - Generated by Perlito6 9.0 2use v5; 3use utf8; 4use strict; 5use warnings; 6no warnings ('redefine', 'once', 'void', 'uninitialized', 'misc', 'recursion'); 7use Perlito6::Perl5::Runtime; 8use Perlito6::Perl5::Prelude; 9our $MATCH = Perlito6::Match->new(); 10{ 11package GLOBAL; 12 sub new { shift; bless { @_ }, "GLOBAL" } 13 14 # use v6 15; 16 { 17 package Perlito6::Lisp::LexicalBlock; 18 sub new { shift; bless { @_ }, "Perlito6::Lisp::LexicalBlock" } 19 sub block { $_[0]->{block} }; 20 sub emit_lisp { 21 my $self = $_[0]; 22 (my $List_block = bless [], 'ARRAY'); 23 for ( @{(defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))} ) { 24 if (defined($_)) { 25 push( @{$List_block}, $_ ) 26 } 27 }; 28 if (!(((defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))))) { 29 return scalar ('nil') 30 }; 31 ((my $str) = ''); 32 ((my $has_my_decl) = 0); 33 ((my $my_decl) = ''); 34 ((my $my_ignore) = ''); 35 (my $Hash_decl_seen = bless {}, 'HASH'); 36 for my $decl ( @{(defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))} ) { 37 if ((Main::isa($decl, 'Decl') && (($decl->decl() eq 'my')))) { 38 ((my $var_name) = ($decl->var())->emit_lisp()); 39 if (!(($Hash_decl_seen->{$var_name}))) { 40 ($has_my_decl = 1); 41 ($my_decl = ($my_decl . Decl::emit_lisp_initializer($decl->var()))); 42 ($my_ignore = ($my_ignore . '(declare (ignorable ' . $var_name . ('))' . chr(10)))); 43 ($Hash_decl_seen->{$var_name} = 1) 44 } 45 }; 46 if (((Main::isa($decl, 'Bind') && Main::isa(($decl->parameters()), 'Decl')) && ((($decl->parameters())->decl() eq 'my')))) { 47 ((my $var_name) = (($decl->parameters())->var())->emit_lisp()); 48 if (!(($Hash_decl_seen->{$var_name}))) { 49 ($has_my_decl = 1); 50 ($my_decl = ($my_decl . Decl::emit_lisp_initializer(($decl->parameters())->var()))); 51 ($my_ignore = ($my_ignore . '(declare (ignorable ' . $var_name . ('))' . chr(10)))); 52 ($Hash_decl_seen->{$var_name} = 1) 53 } 54 } 55 }; 56 if ($has_my_decl) { 57 ($str = ($str . '(let (' . $my_decl . (')' . chr(10)) . $my_ignore)) 58 } 59 else { 60 ($str = ($str . '(progn ')) 61 }; 62 for my $decl ( @{(defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))} ) { 63 if ((!(((Main::isa($decl, 'Decl') && (($decl->decl() eq 'my'))))))) { 64 ($str = ($str . ($decl)->emit_lisp())) 65 } 66 }; 67 return scalar (($str . ')')) 68 } 69 } 70 71; 72 { 73 package CompUnit; 74 sub new { shift; bless { @_ }, "CompUnit" } 75 sub attributes { $_[0]->{attributes} }; 76 sub methods { $_[0]->{methods} }; 77 sub emit_lisp { 78 my $self = $_[0]; 79 ((my $class_name) = Main::to_lisp_namespace($self->{name})); 80 ((my $str) = (chr(59) . chr(59) . ' class ' . $self->{name} . (chr(10)))); 81 ((my $has_my_decl) = 0); 82 ((my $my_decl) = ''); 83 ((my $my_ignore) = ''); 84 (my $Hash_decl_seen = bless {}, 'HASH'); 85 for my $decl ( @{(defined $self->{body} ? $self->{body} : ($self->{body} ||= bless([], 'ARRAY')))} ) { 86 if ((Main::isa($decl, 'Decl') && (($decl->decl() eq 'my')))) { 87 ((my $var_name) = ($decl->var())->emit_lisp()); 88 if (!(($Hash_decl_seen->{$var_name}))) { 89 ($has_my_decl = 1); 90 ($my_decl = ($my_decl . Decl::emit_lisp_initializer($decl->var()))); 91 ($my_ignore = ($my_ignore . '(declare (ignorable ' . $var_name . ('))' . chr(10)))); 92 ($Hash_decl_seen->{$var_name} = 1) 93 } 94 }; 95 if (((Main::isa($decl, 'Bind') && Main::isa(($decl->parameters()), 'Decl')) && ((($decl->parameters())->decl() eq 'my')))) { 96 ((my $var_name) = (($decl->parameters())->var())->emit_lisp()); 97 if (!(($Hash_decl_seen->{$var_name}))) { 98 ($has_my_decl = 1); 99 ($my_decl = ($my_decl . Decl::emit_lisp_initializer(($decl->parameters())->var()))); 100 ($my_ignore = ($my_ignore . '(declare (ignorable ' . $var_name . ('))' . chr(10)))); 101 ($Hash_decl_seen->{$var_name} = 1) 102 } 103 } 104 }; 105 if ($has_my_decl) { 106 ($str = ($str . '(let (' . $my_decl . (')' . chr(10)) . $my_ignore)) 107 }; 108 ((my $dumper) = ''); 109 for my $decl ( @{(defined $self->{body} ? $self->{body} : ($self->{body} ||= bless([], 'ARRAY')))} ) { 110 if ((Main::isa($decl, 'Decl') && (($decl->decl() eq 'has')))) { 111 ((my $accessor_name) = ($decl->var())->name()); 112 ($dumper = ($dumper . '(let ((m (make-instance ' . chr(39) . 'mp-Pair))) ' . '(setf (sv-key m) ' . chr(34) . Main::lisp_escape_string($accessor_name) . chr(34) . ') ' . '(setf (sv-value m) (' . Main::to_lisp_identifier($accessor_name) . ' self)) m) ')) 113 }; 114 if (Main::isa($decl, 'Method')) { 115 ((my $sig) = $decl->sig()); 116 ((my $invocant) = $sig->invocant()); 117 ((my $pos) = $sig->positional()); 118 ((my $str_specific) = ('(' . $invocant->emit_lisp() . ' ' . $class_name . ')')); 119 ((my $str_optionals) = ''); 120 ((my $ignorable) = ''); 121 for my $field ( @{($pos)} ) { 122 ($str_optionals = ($str_optionals . ' ' . $field->emit_lisp())); 123 ($ignorable = ($ignorable . (chr(10)) . ' (declare (ignorable ' . $field->emit_lisp() . ('))'))) 124 }; 125 if (($str_optionals)) { 126 ($str_specific = ($str_specific . ' ' . chr(38) . 'optional' . $str_optionals)) 127 }; 128 ((my $block) = Perlito6::Lisp::LexicalBlock->new(('block' => $decl->block()))); 129 ($str = ($str . chr(59) . chr(59) . ' method ' . $decl->name() . (chr(10)) . '(defmethod ' . Main::to_lisp_identifier($decl->name()) . ' (' . $str_specific . ')' . $ignorable . (chr(10)) . ' (block mp6-function' . (chr(10)) . ' ' . $block->emit_lisp() . ('))' . chr(10)))) 130 }; 131 if (Main::isa($decl, 'Sub')) { 132 ((my $pos) = ($decl->sig())->positional()); 133 (my $param); 134 ((my $ignorable) = ''); 135 if (($pos)) { 136 for my $field ( @{($pos)} ) { 137 ($param = ($param . $field->emit_lisp() . ' ')); 138 ($ignorable = ($ignorable . (chr(10)) . ' (declare (ignorable ' . $field->emit_lisp() . ('))'))) 139 } 140 }; 141 ((my $sig) = ''); 142 if ($param) { 143 ($sig = (chr(38) . 'optional ' . $param)) 144 }; 145 ((my $block) = Perlito6::Lisp::LexicalBlock->new(('block' => $decl->block()))); 146 ($str = ($str . '(defmethod ' . $class_name . '-' . Main::to_lisp_identifier($decl->name()) . ' (' . $sig . ')' . $ignorable . (chr(10)) . ' (block mp6-function ' . $block->emit_lisp() . '))' . (chr(10)) . '(in-package ' . $class_name . ')' . (chr(10)) . ' (defun ' . Main::to_lisp_identifier($decl->name()) . ' (' . $sig . ')' . (chr(10)) . ' (mp-Main::' . $class_name . '-' . Main::to_lisp_identifier($decl->name()) . ' ' . $param . '))' . (chr(10)) . '(in-package mp-Main)' . (chr(10)))) 147 } 148 }; 149 if (($self->{name} ne 'Pair')) { 150 ($str = ($str . '(defmethod sv-perl ((self ' . $class_name . '))' . (chr(10)) . ' (mp-Main-sv-lisp_dump_object ' . chr(34) . Main::lisp_escape_string($self->{name}) . chr(34) . ' (list ' . $dumper . ')))' . (chr(10)) . (chr(10)))) 151 }; 152 ($str = ($str . '(defun run-' . $class_name . ' ()' . (chr(10)))); 153 for my $decl ( @{(defined $self->{body} ? $self->{body} : ($self->{body} ||= bless([], 'ARRAY')))} ) { 154 if ((((!(((Main::isa($decl, 'Decl') && (((($decl->decl() eq 'has')) || (($decl->decl() eq 'my')))))))) && (!((Main::isa($decl, 'Method'))))) && (!((Main::isa($decl, 'Sub')))))) { 155 ($str = ($str . ($decl)->emit_lisp() . (chr(10)))) 156 } 157 }; 158 ($str = ($str . ')' . (chr(10)))); 159 if ($has_my_decl) { 160 ($str = ($str . ')')) 161 }; 162 ($str = ($str . (chr(10)) . (chr(10)))) 163 }; 164 sub emit_lisp_program { 165 my $comp_units = $_[0]; 166 ((my $str) = ''); 167 (my $Hash_unit_seen = bless {}, 'HASH'); 168 (my $List_tmp_comp_unit = bless [], 'ARRAY'); 169 for my $comp_unit ( @{(($comp_units))} ) { 170 ((my $name) = $comp_unit->name()); 171 if ($Hash_unit_seen->{$name}) { 172 for my $stmt ( @{(($comp_unit->body()))} ) { 173 push( @{($Hash_unit_seen->{$name})->body()}, $stmt ) 174 } 175 } 176 else { 177 ($Hash_unit_seen->{$name} = $comp_unit); 178 push( @{$List_tmp_comp_unit}, $comp_unit ) 179 } 180 }; 181 ($comp_units = $List_tmp_comp_unit); 182 for my $comp_unit ( @{(($comp_units))} ) { 183 for my $stmt ( @{(($comp_unit->body()))} ) { 184 if (Main::isa($stmt, 'Method')) { 185 (($comp_unit->methods())->{$stmt->name()} = $stmt) 186 }; 187 if ((Main::isa($stmt, 'Decl') && (($stmt->decl() eq 'has')))) { 188 (($comp_unit->attributes())->{($stmt->var())->name()} = $stmt) 189 } 190 } 191 }; 192 for my $comp_unit ( @{(($comp_units))} ) { 193 ((my $class_name) = Main::to_lisp_namespace($comp_unit->name())); 194 if (($class_name ne 'mp-Main')) { 195 ($str = ($str . '(defpackage ' . $class_name . (chr(10)) . ' (:use common-lisp mp-Main))' . (chr(10)))) 196 }; 197 ($str = ($str . '(if (not (ignore-errors (find-class ' . chr(39) . $class_name . ')))' . (chr(10)) . ' (defclass ' . $class_name . ' () ()))' . (chr(10)))); 198 ($str = ($str . '(let (x)' . (chr(10)) . ' (setq x (make-instance ' . chr(39) . $class_name . ('))' . chr(10)) . ' (defun proto-' . $class_name . ' () x))' . (chr(10)))); 199 for my $decl ( @{(($comp_unit->body()))} ) { 200 if ((Main::isa($decl, 'Decl') && (($decl->decl() eq 'has')))) { 201 ((my $accessor_name) = ($decl->var())->name()); 202 ($str = ($str . chr(59) . chr(59) . ' has ' . chr(36) . '.' . $accessor_name . (chr(10)) . '(let ((new-slots (list (list :name ' . chr(39) . Main::to_lisp_identifier($accessor_name) . chr(10) . ' :readers ' . chr(39) . '(' . Main::to_lisp_identifier($accessor_name) . ')' . chr(10) . ' :writers ' . chr(39) . '((setf ' . Main::to_lisp_identifier($accessor_name) . '))' . chr(10) . ' :initform ' . chr(39) . '(sv-undef)' . chr(10) . ' :initfunction (constantly (sv-undef))))))' . chr(10) . '(dolist (slot-defn (sb-mop:class-direct-slots (find-class ' . chr(39) . $class_name . ')))' . chr(10) . '(push (list :name (sb-mop:slot-definition-name slot-defn)' . chr(10) . ' :readers (sb-mop:slot-definition-readers slot-defn)' . chr(10) . ' :writers (sb-mop:slot-definition-writers slot-defn)' . chr(10) . ' :initform (sb-mop:slot-definition-initform slot-defn)' . chr(10) . ' :initfunction (sb-mop:slot-definition-initfunction slot-defn))' . chr(10) . 'new-slots))' . chr(10) . '(sb-mop:ensure-class ' . chr(39) . $class_name . ' :direct-slots new-slots))' . (chr(10) . chr(10)))) 203 }; 204 if (Main::isa($decl, 'Method')) { 205 ((my $sig) = $decl->sig()); 206 ((my $invocant) = $sig->invocant()); 207 ((my $pos) = $sig->positional()); 208 ((my $str_generic) = $invocant->emit_lisp()); 209 ((my $str_optionals) = ''); 210 for my $field ( @{($pos)} ) { 211 ($str_optionals = ($str_optionals . ' ' . $field->emit_lisp())) 212 }; 213 if (($str_optionals)) { 214 ($str_generic = ($str_generic . ' ' . chr(38) . 'optional' . $str_optionals)) 215 }; 216 ($str = ($str . chr(59) . chr(59) . ' method ' . $decl->name() . (chr(10)) . '(if (not (ignore-errors (find-method ' . chr(39) . Main::to_lisp_identifier($decl->name()) . ' () ())))' . chr(10) . ' (defgeneric ' . Main::to_lisp_identifier($decl->name()) . ' (' . $str_generic . ')' . (chr(10)) . ' (:documentation ' . chr(34) . 'a method' . chr(34) . ')))' . (chr(10)))) 217 }; 218 if (Main::isa($decl, 'Sub')) { 219 ((my $pos) = ($decl->sig())->positional()); 220 (my $param); 221 if (($pos)) { 222 for my $field ( @{($pos)} ) { 223 ($param = ($param . $field->emit_lisp() . ' ')) 224 } 225 }; 226 ((my $sig) = ''); 227 if ($param) { 228 ($sig = (chr(38) . 'optional ' . $param)) 229 }; 230 ($str = ($str . chr(59) . chr(59) . ' sub ' . $decl->name() . (chr(10)) . '(if (not (ignore-errors (find-method ' . chr(39) . $class_name . '-' . Main::to_lisp_identifier($decl->name()) . ' () ())))' . chr(10) . ' (defgeneric ' . $class_name . '-' . Main::to_lisp_identifier($decl->name()) . ' (' . $sig . ')' . (chr(10)) . ' (:documentation ' . chr(34) . 'a method' . chr(34) . ')))' . (chr(10)))) 231 } 232 } 233 }; 234 for my $comp_unit ( @{(($comp_units))} ) { 235 ($str = ($str . $comp_unit->emit_lisp() . (chr(10)))) 236 }; 237 ($str = ($str . ('(defun compiler-main ()' . chr(10)) . (' (progn' . chr(10)) . (' (init-argv)'))); 238 for my $comp_unit ( @{(($comp_units))} ) { 239 ($str = ($str . (chr(10) . ' (run-') . Main::to_lisp_namespace($comp_unit->name()) . (')'))) 240 }; 241 ($str = ($str . ('))' . chr(10)))); 242 return scalar ($str) 243 } 244 } 245 246; 247 { 248 package Val::Int; 249 sub new { shift; bless { @_ }, "Val::Int" } 250 sub emit_lisp { 251 my $self = $_[0]; 252 $self->{int} 253 } 254 } 255 256; 257 { 258 package Val::Bit; 259 sub new { shift; bless { @_ }, "Val::Bit" } 260 sub emit_lisp { 261 my $self = $_[0]; 262 ($self->{bit} ? 'T' : 'nil') 263 } 264 } 265 266; 267 { 268 package Val::Num; 269 sub new { shift; bless { @_ }, "Val::Num" } 270 sub emit_lisp { 271 my $self = $_[0]; 272 $self->{num} 273 } 274 } 275 276; 277 { 278 package Val::Buf; 279 sub new { shift; bless { @_ }, "Val::Buf" } 280 sub emit_lisp { 281 my $self = $_[0]; 282 (chr(34) . Main::lisp_escape_string($self->{buf}) . chr(34)) 283 } 284 } 285 286; 287 { 288 package Lit::Array; 289 sub new { shift; bless { @_ }, "Lit::Array" } 290 sub emit_lisp { 291 my $self = $_[0]; 292 ((my $ast) = $self->expand_interpolation()); 293 return scalar ($ast->emit_lisp()) 294 } 295 } 296 297; 298 { 299 package Lit::Hash; 300 sub new { shift; bless { @_ }, "Lit::Hash" } 301 sub emit_lisp { 302 my $self = $_[0]; 303 ((my $ast) = $self->expand_interpolation()); 304 return scalar ($ast->emit_lisp()) 305 } 306 } 307 308; 309 { 310 package Index; 311 sub new { shift; bless { @_ }, "Index" } 312 sub emit_lisp { 313 my $self = $_[0]; 314 return scalar (('(mp-Main::sv-array-index ' . $self->{obj}->emit_lisp() . ' ' . $self->{index_exp}->emit_lisp() . ')')) 315 } 316 } 317 318; 319 { 320 package Lookup; 321 sub new { shift; bless { @_ }, "Lookup" } 322 sub emit_lisp { 323 my $self = $_[0]; 324 return scalar (('(mp-Main::sv-hash-lookup ' . $self->{index_exp}->emit_lisp() . ' ' . $self->{obj}->emit_lisp() . ')')) 325 } 326 } 327 328; 329 { 330 package Var; 331 sub new { shift; bless { @_ }, "Var" } 332 sub emit_lisp { 333 my $self = $_[0]; 334 ((my $ns) = ''); 335 if ($self->{namespace}) { 336 ($ns = (Main::to_lisp_namespace($self->{namespace}) . '-')) 337 } 338 else { 339 if ((((($self->{sigil} eq chr(64))) && (($self->{twigil} eq '*'))) && (($self->{name} eq 'ARGS')))) { 340 return scalar ('*mp6-args*') 341 } 342 }; 343 ((($self->{twigil} eq '.')) ? (('(' . Main::to_lisp_identifier($self->{name}) . ' sv-self)')) : (((($self->{name} eq chr(47))) ? (Main::to_lisp_identifier('MATCH')) : (($ns . Main::to_lisp_identifier($self->{name})))))) 344 } 345 } 346 347; 348 { 349 package Bind; 350 sub new { shift; bless { @_ }, "Bind" } 351 sub parameters { $_[0]->{parameters} }; 352 sub arguments { $_[0]->{arguments} }; 353 sub emit_lisp { 354 my $self = $_[0]; 355 if ((Main::isa($self->{parameters}, 'Decl') && (($self->{parameters}->decl() eq 'my')))) { 356 return scalar (('(setf ' . ($self->{parameters}->var())->emit_lisp() . ' ' . $self->{arguments}->emit_lisp() . ')')) 357 }; 358 ('(setf ' . $self->{parameters}->emit_lisp() . ' ' . $self->{arguments}->emit_lisp() . ')') 359 } 360 } 361 362; 363 { 364 package Proto; 365 sub new { shift; bless { @_ }, "Proto" } 366 sub emit_lisp { 367 my $self = $_[0]; 368 ('(proto-' . Main::to_lisp_namespace($self->{name}) . ')') 369 } 370 } 371 372; 373 { 374 package Call; 375 sub new { shift; bless { @_ }, "Call" } 376 sub emit_lisp { 377 my $self = $_[0]; 378 ((my $arguments) = Main::join(([ map { $_->emit_lisp() } @{( (defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY'))) )} ]), ' ')); 379 ((my $invocant) = $self->{invocant}->emit_lisp()); 380 if (($invocant eq '(proto-mp-self)')) { 381 ($invocant = 'sv-self') 382 }; 383 if (($self->{method} eq 'isa')) { 384 if (((((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[0])->buf()) eq 'Str')) { 385 return scalar (('(typep ' . $invocant . ' ' . chr(39) . 'string)')) 386 }; 387 return scalar (('(typep ' . $invocant . ' ' . chr(39) . Main::to_lisp_namespace(((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[0])->buf()) . ')')) 388 }; 389 if (($self->{method} eq 'chars')) { 390 if (($self->{hyper})) { 391 die(('not implemented')) 392 } 393 else { 394 return scalar (('(length ' . $invocant . ')')) 395 } 396 }; 397 if (((($self->{method} eq 'yaml')) || (($self->{method} eq 'say')))) { 398 if (($self->{hyper})) { 399 return scalar (('[ map ' . chr(123) . ' ' . $self->{method} . '( ' . chr(36) . '_, ' . ', ' . $arguments . ')' . ' ' . chr(125) . ' ' . chr(64) . chr(123) . ' ' . $invocant . ' ' . chr(125) . ' ]')) 400 } 401 else { 402 return scalar (('(' . $self->{method} . ' ' . $invocant . ' ' . $arguments . ')')) 403 } 404 }; 405 ((my $meth) = (Main::to_lisp_identifier($self->{method}) . ' ')); 406 if (($self->{method} eq 'postcircumfix:<( )>')) { 407 return scalar (('(funcall ' . $invocant . ' ' . $arguments . ')')) 408 }; 409 if (($self->{hyper})) { 410 return scalar (('(map ' . chr(39) . 'vector ' . chr(35) . chr(39) . '(lambda (c) (' . $meth . ' c)) ' . $invocant . ')')) 411 } 412 else { 413 return scalar (('(' . $meth . $invocant . ' ' . $arguments . ')')) 414 } 415 } 416 } 417 418; 419 { 420 package Apply; 421 sub new { shift; bless { @_ }, "Apply" } 422 sub emit_lisp { 423 my $self = $_[0]; 424 ((my $ns) = ''); 425 if ($self->{namespace}) { 426 ($ns = (Main::to_lisp_namespace($self->{namespace}) . '-')) 427 }; 428 ((my $code) = ($ns . $self->{code})); 429 if (($code eq 'infix:<' . chr(126) . '>')) { 430 return scalar (('(concatenate ' . chr(39) . 'string (sv-string ' . ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[0])->emit_lisp() . ') (sv-string ' . ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[1])->emit_lisp() . '))')) 431 }; 432 if (($code eq 'ternary:<' . chr(63) . chr(63) . ' ' . chr(33) . chr(33) . '>')) { 433 return scalar (('(if (sv-bool ' . ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[0])->emit_lisp() . ') ' . ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[1])->emit_lisp() . ' ' . ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[2])->emit_lisp() . ')')) 434 }; 435 ((my $args) = ''); 436 if ((defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))) { 437 ($args = Main::join(([ map { $_->emit_lisp() } @{( (defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY'))) )} ]), ' ')) 438 }; 439 if (($code eq 'self')) { 440 return scalar ('sv-self') 441 }; 442 if (($code eq 'False')) { 443 return scalar ('nil') 444 }; 445 if (($code eq 'True')) { 446 return scalar ('T') 447 }; 448 if (($code eq 'make')) { 449 return scalar (('(setf (sv-capture sv-MATCH) ' . $args . ')')) 450 }; 451 if (($code eq 'substr')) { 452 return scalar (('(sv-substr ' . $args . ')')) 453 }; 454 if (($code eq 'say')) { 455 return scalar (('(mp-Main::sv-say (list ' . $args . '))')) 456 }; 457 if (($code eq 'print')) { 458 return scalar (('(mp-Main::sv-print (list ' . $args . '))')) 459 }; 460 if (($code eq 'warn')) { 461 return scalar (('(write-line (format nil ' . chr(34) . chr(126) . chr(123) . chr(126) . 'a' . chr(126) . chr(125) . chr(34) . ' (list ' . $args . ')) *error-output*)')) 462 }; 463 if (($code eq 'die')) { 464 return scalar (('(progn (write-line (format nil ' . chr(34) . chr(126) . chr(123) . chr(126) . 'a' . chr(126) . chr(125) . chr(34) . ' (list ' . $args . ')) *error-output*) (sb-ext:quit))')) 465 }; 466 if (($code eq 'array')) { 467 return scalar ($args) 468 }; 469 if (($code eq 'exists')) { 470 ((my $arg) = (defined $self->{arguments} ? $self->{arguments} : ($self->{arguments} ||= bless([], 'ARRAY')))->[0]); 471 if (Main::isa($arg, 'Lookup')) { 472 return scalar (('(nth-value 1 ' . $arg->emit_lisp() . ')')) 473 } 474 }; 475 if (($code eq 'list:<' . chr(126) . '>')) { 476 return scalar (('(sv-string ' . $args . ')')) 477 }; 478 if (($code eq 'prefix:<' . chr(33) . '>')) { 479 return scalar (('(not (sv-bool ' . $args . '))')) 480 }; 481 if (($code eq 'prefix:<' . chr(63) . '>')) { 482 return scalar (('(sv-bool ' . $args . ')')) 483 }; 484 if (($code eq 'prefix:<' . chr(36) . '>')) { 485 return scalar (('(sv-scalar ' . $args . ')')) 486 }; 487 if (($code eq 'prefix:<' . chr(64) . '>')) { 488 return scalar ($args) 489 }; 490 if (($code eq 'prefix:<' . chr(37) . '>')) { 491 return scalar ($args) 492 }; 493 if (($code eq 'infix:<+>')) { 494 return scalar (('(sv-add ' . $args . ')')) 495 }; 496 if (($code eq 'infix:<->')) { 497 return scalar (('(sv-sub ' . $args . ')')) 498 }; 499 if (($code eq 'infix:<*>')) { 500 return scalar (('(sv-mul ' . $args . ')')) 501 }; 502 if (($code eq 'infix:<' . chr(47) . '>')) { 503 return scalar (('(sv-div ' . $args . ')')) 504 }; 505 if (($code eq 'infix:<>>')) { 506 return scalar (('(sv-numeric-bigger ' . $args . ')')) 507 }; 508 if (($code eq 'infix:<<>')) { 509 return scalar (('(sv-numeric-smaller ' . $args . ')')) 510 }; 511 if (($code eq 'infix:<>' . chr(61) . '>')) { 512 return scalar (('(sv-numeric-bigger-equal ' . $args . ')')) 513 }; 514 if (($code eq 'infix:<<' . chr(61) . '>')) { 515 return scalar (('(sv-numeric-smaller-equal ' . $args . ')')) 516 }; 517 if (($code eq 'infix:<' . chr(61) . chr(61) . '>')) { 518 return scalar (('(sv-numeric-equal ' . $args . ')')) 519 }; 520 if (($code eq 'infix:<' . chr(33) . chr(61) . '>')) { 521 return scalar (('(not (sv-numeric-equal ' . $args . '))')) 522 }; 523 if (($code eq 'infix:<' . chr(38) . chr(38) . '>')) { 524 return scalar (('(sv-and ' . $args . ')')) 525 }; 526 if (($code eq 'infix:<' . chr(124) . chr(124) . '>')) { 527 return scalar (('(sv-or ' . $args . ')')) 528 }; 529 if (($code eq 'infix:<eq>')) { 530 return scalar (('(sv-eq ' . $args . ')')) 531 }; 532 if (($code eq 'infix:<ne>')) { 533 return scalar (('(not (sv-eq ' . $args . '))')) 534 }; 535 if (($code eq 'circumfix:<( )>')) { 536 return scalar ($args) 537 }; 538 return scalar (('(' . $ns . Main::to_lisp_identifier($self->{code}) . ' ' . $args . ')')) 539 } 540 } 541 542; 543 { 544 package Return; 545 sub new { shift; bless { @_ }, "Return" } 546 sub emit_lisp { 547 my $self = $_[0]; 548 return scalar (('(return-from mp6-function ' . $self->{result}->emit_lisp() . ')')) 549 } 550 } 551 552; 553 { 554 package If; 555 sub new { shift; bless { @_ }, "If" } 556 sub emit_lisp { 557 my $self = $_[0]; 558 ((my $block1) = Perlito6::Lisp::LexicalBlock->new(('block' => $self->{body}->stmts()))); 559 if ($self->{otherwise}) { 560 ((my $block2) = Perlito6::Lisp::LexicalBlock->new(('block' => $self->{otherwise}->stmts()))); 561 return scalar (('(if (sv-bool ' . $self->{cond}->emit_lisp() . ') ' . $block1->emit_lisp() . ' ' . $block2->emit_lisp() . ')')) 562 } 563 else { 564 return scalar (('(if (sv-bool ' . $self->{cond}->emit_lisp() . ') ' . $block1->emit_lisp() . ')')) 565 } 566 } 567 } 568 569; 570 { 571 package For; 572 sub new { shift; bless { @_ }, "For" } 573 sub emit_lisp { 574 my $self = $_[0]; 575 ((my $cond) = $self->{cond}); 576 ((my $block) = Perlito6::Lisp::LexicalBlock->new(('block' => (defined $self->{body} ? $self->{body} : ($self->{body} ||= bless([], 'ARRAY')))))); 577 if ((Main::isa($cond, 'Var') && ($cond->sigil() eq chr(64)))) { 578 ($cond = Apply->new(('code' => 'prefix:<' . chr(64) . '>'), ('arguments' => do { 579 (my $List_a = bless [], 'ARRAY'); 580 (my $List_v = bless [], 'ARRAY'); 581 push( @{$List_a}, $cond ); 582 $List_a 583}))) 584 }; 585 ('(loop for ' . $self->{topic}->emit_lisp() . ' across ' . $cond->emit_lisp() . ' do ' . $block->emit_lisp() . ')') 586 } 587 } 588 589; 590 { 591 package While; 592 sub new { shift; bless { @_ }, "While" } 593 sub emit_lisp { 594 my $self = $_[0]; 595 ((my $List_body = bless [], 'ARRAY') = (defined $self->{body} ? $self->{body} : ($self->{body} ||= bless([], 'ARRAY')))); 596 if ($self->{continue}) { 597 push( @{$List_body}, $self->{continue} ) 598 }; 599 ('(progn ' . (($self->{init} ? ($self->{init}->emit_lisp() . ' ') : '')) . '(loop while (sv-bool ' . $self->{cond}->emit_lisp() . ') do ' . (Perlito6::Lisp::LexicalBlock->new(('block' => $List_body)))->emit_lisp() . '))') 600 } 601 } 602 603; 604 { 605 package Decl; 606 sub new { shift; bless { @_ }, "Decl" } 607 sub emit_lisp { 608 my $self = $_[0]; 609 ((my $decl) = $self->{decl}); 610 ((my $name) = $self->{var}->name()); 611 ((($decl eq 'has')) ? (('sub ' . $name . ' ' . chr(123) . ' ' . chr(64) . '_ ' . chr(61) . chr(61) . ' 1 ' . chr(63) . ' ( ' . chr(36) . '_[0]->' . chr(123) . $name . chr(125) . ' ) ' . ': ( ' . chr(36) . '_[0]->' . chr(123) . $name . chr(125) . ' ' . chr(61) . ' ' . chr(36) . '_[1] ) ' . chr(125))) : ($self->{decl} . ' ' . $self->{type} . ' ' . $self->{var}->emit_lisp())) 612 }; 613 sub emit_lisp_initializer { 614 my $decl = $_[0]; 615 if (($decl->sigil() eq chr(37))) { 616 return scalar (('(' . $decl->emit_lisp() . ' (make-hash-table :test ' . chr(39) . 'equal))')) 617 } 618 else { 619 if (($decl->sigil() eq chr(64))) { 620 return scalar (('(' . $decl->emit_lisp() . ' (make-array 0 :fill-pointer t :adjustable t))')) 621 } 622 else { 623 return scalar (('(' . $decl->emit_lisp() . ' (sv-undef))')) 624 } 625 } 626 } 627 } 628 629; 630 { 631 package Method; 632 sub new { shift; bless { @_ }, "Method" } 633 sub emit_lisp { 634 my $self = $_[0]; 635 636 } 637 } 638 639; 640 { 641 package Sub; 642 sub new { shift; bless { @_ }, "Sub" } 643 sub emit_lisp { 644 my $self = $_[0]; 645 ((my $sig) = $self->{sig}); 646 ((my $pos) = $sig->positional()); 647 ((my $block) = Perlito6::Lisp::LexicalBlock->new(('block' => (defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))))); 648 (my $str); 649 if (($pos)) { 650 for my $field ( @{($pos)} ) { 651 ($str = ($str . $field->emit_lisp() . ' ')) 652 } 653 }; 654 if ($str) { 655 ($str = (chr(38) . 'optional ' . $str)) 656 }; 657 if ($self->{name}) { 658 ('(defun ' . Main::to_lisp_identifier($self->{name}) . ' (' . $str . ')' . (chr(10)) . ' (block mp6-function ' . $block->emit_lisp() . '))' . (chr(10))) 659 } 660 else { 661 ('(lambda ' . $self->{name} . ' (' . $str . ')' . (chr(10)) . ' (block mp6-function ' . $block->emit_lisp() . '))' . (chr(10))) 662 } 663 } 664 } 665 666; 667 { 668 package Do; 669 sub new { shift; bless { @_ }, "Do" } 670 sub emit_lisp { 671 my $self = $_[0]; 672 ((my $block) = Perlito6::Lisp::LexicalBlock->new(('block' => (defined $self->{block} ? $self->{block} : ($self->{block} ||= bless([], 'ARRAY')))))); 673 return scalar ($block->emit_lisp()) 674 } 675 } 676 677; 678 { 679 package Use; 680 sub new { shift; bless { @_ }, "Use" } 681 sub emit_lisp { 682 my $self = $_[0]; 683 (chr(10) . chr(59) . chr(59) . ' use ' . Main::to_lisp_namespace($self->{mod}) . (chr(10))) 684 } 685 } 686 687 688} 689 6901; 691