Changeset 22560

Timestamp:

10/10/08 01:03:49 (6 weeks ago)

Author:

putter

Message:

[elfish/on_sbcl] Self-compiles.
Undef and bool boxing. Dispatch and misc fixes. Slower.
Doesn't quite compile the p5 version.
[STD_red] Improved --format=cl string and nil dumping.
[elf_h] Yet more missing argument fixes.

Location:

misc

Files:

• STD_red/match.rb (modified) (3 diffs)
• elf/elf_h (modified) (5 diffs)
• elf/elf_h_src/EmitSimpleP5.pm (modified) (2 diffs)
• elf/elf_h_src/IRx1_FromAST.pm (modified) (2 diffs)
• elf/elf_h_src/IRx1_FromAST_create.pl (modified) (2 diffs)
• elfish/on_sbcl/EmitSBCL.pm (modified) (12 diffs)
• elfish/on_sbcl/Makefile (modified) (2 diffs)
• elfish/on_sbcl/PrimitivesSBCL.pm (modified) (12 diffs)
• elfish/on_sbcl/README (modified) (1 diff)

misc/STD_red/match.rb

@@ -157 +157 @@
 end
 class String
-  def to_dump1; inspect.gsub(/\n/,"\n").gsub(/\t/,"\t") end
+  def to_dump1; '"'+gsub(/([\\"])/){|w|"\\#{w}"}+'"' end
 end
 class Symbol
@@ -163 +163 @@
 end
 class FalseClass
-  def to_dump1; 'nil' end
+  def to_dump1; ':false' end
 end
 class Fixnum
@@ -171 +171 @@
   def to_dump1
     b = as_b ? '1' : '0'
-    s = '"'+str.gsub(/([\\"])/){|w|"\\#{w}"}+'"'
+    s = str.to_dump1
     h = as_h.map{|k,v|
       vs = v.to_dump1

misc/elf/elf_h

@@ -114 +114 @@
   sub ucfirst  { CORE::ucfirst($_[0]); }
   sub unpack   { CORE::unpack($_[0], @_[1..$#_]); }
-  sub quotemet { CORE::quotemeta($_[0]); }
   sub undef    { $_[0] = undef }
   sub m        { [ $_[0] =~ m{$_[1]} ] }
@@ -2218 +2217 @@
 (do{IRx1::For->newp($m, irbuild_ir($m->hash()->{"modifier_expr"}), $blackboard::statement_expr)})};
 my $construct_statement_control_58while = sub {my($m)=@_;
-(do{IRx1::Loop->newp($m, irbuild_ir($m->hash()->{"expr"}), irbuild_ir($m->hash()->{"block"}))})};
+(do{IRx1::Loop->newp($m, irbuild_ir($m->hash()->{"expr"}), irbuild_ir($m->hash()->{"block"}), GLOBAL::undef(), GLOBAL::undef())})};
 my $construct_statement_mod_loop_58while = sub {my($m)=@_;
-(do{IRx1::Loop->newp($m, irbuild_ir($m->hash()->{"modifier_expr"}), $blackboard::statement_expr)})};
+(do{IRx1::Loop->newp($m, irbuild_ir($m->hash()->{"modifier_expr"}), $blackboard::statement_expr, GLOBAL::undef(), GLOBAL::undef())})};
 my $construct_statement_control_58until = sub {my($m)=@_;
 (do{my $test = IRx1::Apply->newp($m, "not", IRx1::Capture->newp1($m, [irbuild_ir($m->hash()->{"expr"})]));
-IRx1::Loop->newp($m, $test, irbuild_ir($m->hash()->{"block"}))})};
+IRx1::Loop->newp($m, $test, irbuild_ir($m->hash()->{"block"}), GLOBAL::undef(), GLOBAL::undef())})};
 my $construct_statement_mod_loop_58until = sub {my($m)=@_;
 (do{my $test = IRx1::Apply->newp($m, "not", IRx1::Capture->newp1($m, [irbuild_ir($m->hash()->{"modifier_expr"})]));
-IRx1::Loop->newp($m, $test, $blackboard::statement_expr)})};
+IRx1::Loop->newp($m, $test, $blackboard::statement_expr, GLOBAL::undef(), GLOBAL::undef())})};
 my $construct_statement_control_58loop = sub {my($m)=@_;
 (do{my $e1 = irbuild_ir($m->hash()->{"loop_eee"}->hash()->{"loop_e1"});
@@ -2232 +2231 @@
 my $e3 = irbuild_ir($m->hash()->{"loop_eee"}->hash()->{"loop_e3"});
 my $block = irbuild_ir($m->hash()->{"loop_block"});
-my $body = IRx1::Loop->newp($m, $e2, IRx1::Block->newp($m, [$block, $e3]));
+my $body = IRx1::Loop->newp($m, $e2, IRx1::Block->newp($m, [$block, $e3]), GLOBAL::undef(), GLOBAL::undef());
 IRx1::Block->newp($m, [$e1, $body])})};
 my $construct_statement_control_58if = sub {my($m)=@_;
@@ -2957 +2956 @@
 "})
 }})};
-sub prelude{my $self=CORE::shift;my($n)=@_;
-(do{((("\#\!\/usr\/bin\/env\ perl\
+sub prelude{my $self=CORE::shift;(do{((("\#\!\/usr\/bin\/env\ perl\
 use\ strict\;\
 no\ strict\ \"subs\"\;\ \#\ XXX\ remove\ once\ Type\-names\ are\ quoted\.\ \#\ say\ Int\.isa\(Any\)\
@@ -3055 +3053 @@
 \ \ sub\ ucfirst\ \ \{\ CORE\:\:ucfirst\(\$_\[0\]\)\;\ \}\
 \ \ sub\ unpack\ \ \ \{\ CORE\:\:unpack\(\$_\[0\]\,\ \@_\[1\.\.\$\#_\]\)\;\ \}\
-\ \ sub\ quotemet\ \{\ CORE\:\:quotemeta\(\$_\[0\]\)\;\ \}\
 \ \ sub\ undef\ \ \ \ \{\ \$_\[0\]\ \=\ undef\ \}\
 \ \ sub\ m\ \ \ \ \ \ \ \ \{\ \[\ \$_\[0\]\ \=\~\ m\{\$_\[1\]\}\ \]\ \}\

misc/elf/elf_h_src/EmitSimpleP5.pm

@@ -49 +49 @@
     }
   };
-  method prelude ($n) {
+  method prelude {
   '#!/usr/bin/env perl
 use strict;
@@ -147 +147 @@
   sub ucfirst  { CORE::ucfirst($_[0]); }
   sub unpack   { CORE::unpack($_[0], @_[1..$#_]); }
-  sub quotemet { CORE::quotemeta($_[0]); }
   sub undef    { $_[0] = undef }
   sub m        { [ $_[0] =~ m{$_[1]} ] }

misc/elf/elf_h_src/IRx1_FromAST.pm

@@ -343 +343 @@
 
     my $construct_statement_control_58while = sub ($m) {
-      IRx1::Loop.newp($m,irbuild_ir($m.hash{'expr'}),irbuild_ir($m.hash{'block'}));
+      IRx1::Loop.newp($m,irbuild_ir($m.hash{'expr'}),irbuild_ir($m.hash{'block'}),undef,undef);
     };
 
     my $construct_statement_mod_loop_58while = sub ($m) {
-      IRx1::Loop.newp($m,irbuild_ir($m.hash{'modifier_expr'}),$blackboard::statement_expr);
+      IRx1::Loop.newp($m,irbuild_ir($m.hash{'modifier_expr'}),$blackboard::statement_expr,undef,undef);
     };
 
     my $construct_statement_control_58until = sub ($m) {
       my $test = IRx1::Apply.newp($m,"not",IRx1::Capture.newp1($m,[irbuild_ir($m.hash{'expr'})]));
-IRx1::Loop.newp($m,$test,irbuild_ir($m.hash{'block'}));
+IRx1::Loop.newp($m,$test,irbuild_ir($m.hash{'block'}),undef,undef);
     };
 
     my $construct_statement_mod_loop_58until = sub ($m) {
       my $test = IRx1::Apply.newp($m,"not",IRx1::Capture.newp1($m,[irbuild_ir($m.hash{'modifier_expr'})]));
-IRx1::Loop.newp($m,$test,$blackboard::statement_expr);
+IRx1::Loop.newp($m,$test,$blackboard::statement_expr,undef,undef);
     };
 
@@ -365 +365 @@
 my $e3 = irbuild_ir($m.hash{'loop_eee'}.hash{'loop_e3'});
 my $block = irbuild_ir($m.hash{'loop_block'});
-my $body = IRx1::Loop.newp($m,$e2,IRx1::Block.newp($m,[$block,$e3]));
+my $body = IRx1::Loop.newp($m,$e2,IRx1::Block.newp($m,[$block,$e3]),undef,undef);
 IRx1::Block.newp($m,[$e1,$body]);
     };

misc/elf/elf_h_src/IRx1_FromAST_create.pl

@@ -255 +255 @@
 
 statement_control:while
-Loop.newp($m<expr>,$m<block>)
+Loop.newp($m<expr>,$m<block>,undef,undef)
 
 statement_mod_loop:while
-Loop.newp($m<modifier_expr>,$blackboard::statement_expr)
+Loop.newp($m<modifier_expr>,$blackboard::statement_expr,undef,undef)
 
 statement_control:until
 my $test = Apply.newp("not",Capture.newp1([$m<expr>]));
-Loop.newp($test,$m<block>)
+Loop.newp($test,$m<block>,undef,undef)
 
 statement_mod_loop:until
 my $test = Apply.newp("not",Capture.newp1([$m<modifier_expr>]));
-Loop.newp($test,$blackboard::statement_expr)
+Loop.newp($test,$blackboard::statement_expr,undef,undef)
 
 statement_control:loop
@@ -273 +273 @@
 my $e3 = $m<loop_eee><loop_e3>;
 my $block = $m<loop_block>;
-my $body = Loop.newp($e2,Block.newp([$block,$e3]));
+my $body = Loop.newp($e2,Block.newp([$block,$e3]),undef,undef);
 Block.newp([$e1,$body])
 

misc/elfish/on_sbcl/EmitSBCL.pm

@@ -91 +91 @@
 
 (defmacro ncgf-defmethod (name sig &rest body)
-  (let* ((n (1+ *maximum-number-of-dispatch-affecting-variables*))
-         (n-1 (1- n))
-         (vars (parameters-in-lambda-list sig))
-         (len (length vars))
-         (real-vars (subseq vars 0 (min n-1 len)))
-         (bounds-var (list (if (find \'&rest sig)
-                               (gensym)
-                             `(,(gensym) ,(class-of nil)))))
-         (pad-vars (n-gensyms (max 0 (- n-1 len))))
-         (dispatch-vars (concatenate \'list real-vars bounds-var pad-vars))
+  (let* ((n *maximum-number-of-dispatch-affecting-variables*)
+         (params (parameters-in-lambda-list sig))
+         (arity (length params))
+         (real-dispatch-params (subseq params 0 (min arity n)))
+         (an-arity-check-var (gensym))
+         (an-arity-check-param (if (find \'&rest sig)
+                                   an-arity-check-var
+                                 (list an-arity-check-var \'null)))
+         (a-noop-var (gensym))
+         (pad-vars (n-gensyms (max 0 (- n arity))))
+         (fake-dispatch-params
+          (cond ((> arity n) (list a-noop-var))
+                (t (cons an-arity-check-param pad-vars))))
+         (fake-vars
+          (cond ((> arity n) (list a-noop-var))
+                (t (cons an-arity-check-var pad-vars))))
+         (dispatch-params (concatenate \'list
+                                       real-dispatch-params
+                                       fake-dispatch-params))
          (typeless-sig (map \'list (lambda (p) (if (listp p) (car p) p)) sig))
-         (def `(defmethod ,name (args ,@dispatch-vars)
-                 (declare (ignore ,@pad-vars))
+         (def `(defmethod ,name (args ,@dispatch-params)
+                 (declare (ignore ,@fake-vars))
                  (destructuring-bind ,typeless-sig args
                                      ,@body))))
@@ -237 +246 @@
 ;; predecls
 (defclass |Any/cls| () ())
+(defclass |Undef/cls| () ())
 (defclass |Bool/cls| () ())
 (defclass |Int/cls| () ())
 (defclass |Num/cls| () ())
 (defclass |Str/cls| () ())
+
+;; Undef
+(defparameter |Undef::/co| nil)
+(defun undef () |Undef::/co|)
+(defgeneric defined-p (x))
+(defmethod defined-p (x) (declare (ignore x)) t)
+(defmethod defined-p ((x |Undef/cls|)) (declare (ignore x)) nil)
+;; Kludge until a Prim::null is available.
+(dm |M::make_ir_from_Match_tree| ((self null)) (undef))
+
+;; Bool
+(pkg-declare "class" "False" \'|Bool/cls|)
+(pkg-declare "class" "True" \'|Bool/cls|)
+(defun true () |True::/co|)
+(defun false () |False::/co|)
 
 ;;
@@ -258 +283 @@
   (reduce #\'append
           (mapcar (lambda (e)
-                    (if (and (listp e)
-                             ;;(not (null e)) ;#XXX disappears undef args!
-                             ;;# boxing undef is now important. :/
-                             )
-                        e (list e)))
+                    (if (listp e) e (list e)))
                   args)))
 
-;;
+;; Any
 (dm |M::new| ((co |Any/cls|) &rest argl)
-  (declare (ignorable argl))
+  (declare (ignore argl))
   (set-slots (make-instance (class-of co)) argl))
 
@@ -274 +295 @@
       (UP (can-p name self))))
 
-;; Undef is still being kludged as nil.  And Bools.
-(defmacro undef () nil)
-(dm |M::make_ir_from_Match_tree| ((self null) ) (block __f__ (let () self)))
-(dm |M::isa| ((x null) str) (declare (ignorable x)) (equal (S str) "Undef"))
-(dm |M::Str| ((x symbol)) (UP (symbol-name x))) ;X for t
-
  ;;Array.new is defined here to a avoid cyclic dependency on *@args.
 (pkg-declare "class" "Array" \'|Any/cls|)
 (dm |M::new| ((co |Array/cls|) &rest argl)
-  (declare (ignorable co))
+  (declare (ignore co))
   (let ((inst (make-instance \'|Array/cls|)))
     (setf (slot-value inst \'|Array::._native_|)
@@ -289 +304 @@
     inst))
 
-;; Hack until Str, Int, Num, etc are p6 objects.
-(dm |M::Str| ((s string) &rest argl) (declare (ignorable argl)) s)
-(dm |M::Str| ((n number) &rest argl) (declare (ignorable argl)) (write-to-string n))
-(dm |M::WHAT| ((s string) &rest argl) (declare (ignorable s argl)) "str")
-(dm |M::WHAT| ((n number) &rest argl) (declare (ignorable n argl)) "num")
-
-(dm |M::Str| ((x null) &rest argl) (declare (ignorable x argl)) "")
-(dm |M::WHAT| ((x null) &rest argl) (declare (ignorable x argl)) "Undef")
-(dm |M::substr| ((s string) from len) (subseq s from (+ from len)))
-
+;; Primitive Str, Int, Num.
+;(dm |M::WHAT| ((s string)) "str")
+;(dm |M::WHAT| ((n integer)) "int")
+;(dm |M::WHAT| ((n number)) "num")
+;(dm |M::Str| ((s string)) (UP s))
+;(dm |M::Str| ((n number)) (UP (write-to-string n)))
+;(dm |M::substr| ((s string) from len) (subseq s from (+ from len)))
 
 ;; Muffle warnings at compile and runtimes.
 ;(declaim (sb-ext:muffle-conditions style-warning))
-(declaim (sb-ext:muffle-conditions warning))
+;(declaim (sb-ext:muffle-conditions warning))
 
 ;(defparameter sb-ext:*muffled-warnings* style-warning) ;In sbcl-1.0.20 .
@@ -310 +322 @@
 
 ;; UP
-;(defgeneric UP (x))
-(defmethod UP ((x null)) nil)
-(defmethod UP ((x symbol)) x)
+(defmethod UP ((x null)) |False::/co|)
+(defmethod UP ((x symbol)) (if (eq x t) |True::/co| (trigger-debug)))
 (defmethod UP ((x integer)) (fc #\'|M::new| |Int::/co| x))
 (defmethod UP ((x number)) (fc #\'|M::new| |Num::/co| x))
 (defmethod UP ((x string)) (fc #\'|M::new| |Str::/co| x))
-(defmethod UP ((bug |Str/cls|)) (write (S bug)) (die))
+;(defmethod UP ((x |Any/cls|)) x) ; For eventual mixed boxing.
 ;; new-
 (defun new-Array (lst) (ap #\'|M::new| (cons |Array::/co| lst)))
@@ -323 +334 @@
 ;; to-b
 (defgeneric to-b (x))
-(defmethod to-b (x) t)
-(defmethod to-b ((x null)) nil)
-(defmethod to-b ((x symbol)) t) ;for t. #X should check.
-(defmethod to-b ((x string)) (if (equal x "") nil t))
-(defmethod to-b ((x number)) (if (= x 0) nil t))
+(defmethod to-b (x) t) ; Eg, currently unboxed Code.
+(defmethod to-b ((x null)) nil) ;X shouldnt be needed.
+(defmethod to-b ((x string)) (if (equal x "") nil t)) ;X shouldnt be needed.
+(defmethod to-b ((x number)) (if (= x 0) nil t)) ;X shouldnt be needed.
+(defmethod to-b ((x |Any/cls|)) (to-b (fc #\'|M::Bool| x)))
+(defmethod to-b ((x |Undef/cls|)) nil)
 (defmethod to-b ((x |Bool/cls|)) (slot-value x \'|Bool::._native_|))
-(defmethod to-b ((x |Any/cls|)) (to-b (fc #\'|M::Bool| x)))
+(defmethod to-b ((x |False/cls|)) nil)
+(defmethod to-b ((x |True/cls|)) t)
+(defmethod to-b ((x |Int/cls|)) (not (= (slot-value x \'|Int::._native_|) 0)))
+(defmethod to-b ((x |Num/cls|)) (not (= (slot-value x \'|Num::._native_|) 0)))
 ;; to-n
 (defgeneric to-n (x))
-(defmethod to-s ((x null)) 0) ;X unboxed Undef
-(defmethod to-n ((x number)) x)
+(defmethod to-n ((x number)) x) ; For Int.new().
+(defmethod to-n ((x |Any/cls|)) (to-n (fc #\'|M::Num| x)))
 (defmethod to-n ((x |Int/cls|)) (slot-value x \'|Int::._native_|))
 (defmethod to-n ((x |Num/cls|)) (slot-value x \'|Num::._native_|))
-(defmethod to-n ((x |Any/cls|)) (to-n (fc #\'|M::Num| x)))
 ;; to-s
 (defgeneric to-s (x))
-(defmethod to-s ((x null)) "") ;X unboxed Undef
-(defmethod to-s ((x string)) x)
+(defmethod to-s ((x string)) x) ; For Str.new().
 (defmethod to-s ((x |Str/cls|)) (slot-value x \'|Str::._native_|))
 (defmethod to-s ((x |Any/cls|)) (to-s (fc #\'|M::Str| x)))
@@ -356 +369 @@
   (let* ((pat "(?:[^\\\\\\\\$]|\\\\\\\\.|.\\\\z|\\\\$[^{1])+|\\\\$1|\\\\$\\\\{1}")
          (parts (ppcre::all-matches-as-strings pat rep)))
-    (write rep)(write parts)
     (assert (equal (length rep)
                    (length (apply #\'concatenate (cons \'string parts)))))
@@ -366 +378 @@
      parts)))
 
-;; short-circuiting logicals
+;; short-circuiting logicals - codomain is actually domain+t,nil. :/
 (defmacro or6 (&rest args)
   (if (null args)
-      \'nil
+      `(undef)
     (let ((sym (gensym)))
       `(let ((,sym ,(car args)))
          (if (or ,(null (cdr args)) (to-b ,sym)) ,sym (or6 ,@(cdr args)))))))
 (defmacro and6 (&rest args)
-  (cond ((null args) t)
+  (cond ((null args) `(true))
         ((null (cdr args)) (car args))
         (t (let ((sym (gensym)))
-             `(let ((,sym ,(car args))) (if (not (to-b ,sym)) nil (and6 ,@(cdr args))))
+             `(let ((,sym ,(car args))) (if (not (to-b ,sym)) (undef) (and6 ,@(cdr args))))
              ))))
    
@@ -435 +447 @@
        elsif $scope eq 'temp' {
          my $v = $.e($d.var);
-         $lexicals = $lexicals ~ "("~$v~" (if (boundp '"~$v~") "~$v~")) ";
+         $lexicals = $lexicals ~ "("~$v~" (if (boundp '"~$v~") "~$v~" (undef))) ";
        }
     });
@@ -535 +547 @@
     }
     else {
-      if ($sigil eq '$') { $default = 'nil' }#X
+      if ($sigil eq '$') { $default = '(undef)' }
       if ($sigil eq '@') { $default = $.emit_array('') }
       if ($sigil eq '%') { $default = $.emit_hash('') }
@@ -563 +575 @@
       if $default { $evar_d = '(setq '~$evar~' '~$default~')' }
       $whiteboard::declares.push("(declare (special "~$evar~"))\n");
-      my $init = "(unless (boundp '"~$evar~") (setq "~$evar~" nil))\n";
+      my $init = "(unless (boundp '"~$evar~") (setq "~$evar~" (undef)))\n";
       $whiteboard::block_header.push($init);
       $evar_d;

misc/elfish/on_sbcl/Makefile

@@ -10 +10 @@
 elfcl:: have_parser_cache
         ${ELF} -I ${ELFDIR} EmitSBCL.pm -x -o elfcl Elf_SBCL.pm
-        time ${SBCL} --eval '(compile-file "elfcl")' --eval '(quit)' >& elfcl.out
+        /usr/bin/time ${SBCL} --eval '(compile-file "elfcl")' --eval '(quit)' >& elfcl.out
         chmod a+x elfcl
 
@@ -56 +56 @@
         # Create a CL elf.
         ${ELF} -I ${ELFDIR} EmitSBCL.pm -x -o ${TMP}/b0 Elf_SBCL.pm
-        # Compile it, with output to log.
+        # Compile the CL elf.
         ${SBCL} --disable-debugger --eval '(compile-file "${TMP}/b0")' --eval '(quit)' > ${TMP}/b0.log 2>&1
-        # Run it.
+        # Run the CL elf.
         chmod a+x ${TMP}/b0
-        ${TMP}/b0 -e 'say 3'
-        # Check CL bootstrap.
-        ${TMP}/b0 -I ${ELFDIR} -x -o ${TMP}/b1 Elf_SBCL.pm
+        ${TMP}/b0 -e 'say "hello"' 2>/dev/null
+        # Check bootstrap - CL elf compiles a CL elf.
+        ${TMP}/b0 -I ${ELFDIR} -x -o ${TMP}/b1 Elf_SBCL.pm 2>/dev/null
+        # Was it identical?
         diff ${TMP}/b0 ${TMP}/b1
-        # Compile a p5 elf with a CL one.
-        ${TMP}/b0 -I ${ELFDIR} -e 'use EmitSimpleP5' -x -o ${TMP}/a1 -e 'use Elf'
+        # Check cross-bootstrap - CL elf compiles a P5 elf.
+        ${TMP}/b0 -I ${ELFDIR} -e 'use EmitSimpleP5' -x -o ${TMP}/a1 -e 'use Elf' 2>/dev/null
         # Was it identical?
         diff ${TMP}/a0 ${TMP}/a1

misc/elfish/on_sbcl/PrimitivesSBCL.pm

@@ -52 +52 @@
   sub primitive_write_to_string ($x) is cl {' (UP (write-to-string |$x|)) '};
 
-  sub undef () is cl {'
-    nil ;XX
-  '}
+  sub undef () is cl {' (undef) '}
 
   multi infix:<+> ($a,$b) is cl {' (UP (+ (N |$a|) (N |$b|))) '}
@@ -94 +92 @@
 
   multi exit ($status) is cl {' (sb-unix:unix-exit (N |$status|)) '}
+#  multi exit ($status) {}
   multi die ($msg) { say $msg; exit(1); }
 
@@ -104 +103 @@
   multi unlink_ ($filename) is cl {' (sb-unix:unix-unlink (S |$filename|)) '}
   multi not ($x) { if $x { undef } else { 1 } }
-  multi defined ($x) is cl {' (UP (if |$x| 1 nil)) '} ;#X undef as nil
+  multi defined ($x) is cl {' (UP (defined-p |$x|)) '}
   multi substr($s,$offset,$length) { $s.substr($offset,$length) }
 }
@@ -122 +121 @@
       (labels
        ((undump (node)
-           (cond ((null node) (undef))
+           (cond ((null node) nil)
+                 ((eq :false node) (undef))
                  ((listp node)
                   (let ((args (mapcar #\'undump (cdr node))))
@@ -156 +156 @@
     exit(0);
   }
+  sub chmod_exe ($file) is cl {'
+    (sb-posix:chmod (S |$file|)
+                    (logior sb-posix::s-irusr sb-posix::s-iwusr sb-posix::s-ixusr))
+  '}
+
   sub module_require ($module) {
     my $file = find_required_module($module);
@@ -185 +190 @@
     eval_perl6($code,$env);
   }
-
 }
 # regexp elf bootstrap primitives
@@ -203 +207 @@
   '}
 }
-
+# For the Elf P5.
+package GLOBAL {
+  sub mangle_name ($name) is cl {'
+     ; $name =~ s/([^\w])/"_".CORE::ord($1)/eg;
+     (UP (ppcre::regex-replace-all "([^\\\\w])" (S |$name|)
+            (lambda (match g1)
+              (concatenate \'string "_" (write-to-string (char-code (aref g1 0)))))
+            :simple-calls t))
+  '}
+  #sub quotemeta ($str) { $str.re_gsub_pat('([^\\w])','\\\\$1') }
+  sub quotemeta ($str) is cl {' ;#XXX flee backslash insanity
+     (UP (ppcre::regex-replace-all "([^\\\\w])" (S |$str|)
+            (lambda (match g1) (concatenate \'string "\\\\" g1))
+            :simple-calls t))
+  '}
+}
 
 package Main {
@@ -253 +272 @@
   method split ($pat) is cl {'
     (let ((s (slot-value self \'|Str::._native_|)))
-      (new-Array (ppcre::split (S |$pat|) s)))
+      (new-Array (mapcar (lambda (x) (UP x))
+                         (ppcre::split (S |$pat|) s))))
   '}
   method substr ($offset,$length) is cl {'
@@ -340 +360 @@
   method reverse () is cl {'
     (let* ((a (slot-value self \'|Array::._native_|)))
-      (new-Array (reverse a)))
+      (new-Array (coerce (reverse a) \'list ))) ;X
   '}
 }
@@ -400 +420 @@
     (let ((hk (slot-value self \'|Hash::._keys_|))
           (hv (slot-value self \'|Hash::._values_|)))
-      (if (nth-value 1 (gethash (cl-hash |$key|) hk)) t nil))
+      (UP (if (nth-value 1 (gethash (cl-hash |$key|) hk)) t nil)))
   '}
   method delete ($key) is cl {'
@@ -448 +468 @@
 
 # .Num()
+class Undef { method Num () { 0 } }
 class Int   { method Num () { self } }
 class Num   { method Num () { self } }
@@ -457 +478 @@
 # .Str()
 class Any   { method Str () { primitive_write_to_string(self) } }
+class Undef { method Str () { "" } }
+class Bool  { method Str () { if self { "true" } else { "false " } } }
+class True  { method Str () { "true" } }
+class False { method Str () { "false" } }
 class Int   { method Str () { primitive_write_to_string(self._native_) } }
 class Num   { method Str () { primitive_write_to_string(self._native_) } }

misc/elfish/on_sbcl/README

@@ -69 +69 @@
   # This dropped to 1/2x with Int's.
   # This dropped to 1/4x while not being watched, for causes unknown.
+  # This dropped to 1/5x with boxed undef and booleans.