Changeset 22502

Timestamp:

10/04/08 03:12:27 (7 weeks ago)

Author:

putter

Message:

[elfish/on_sbcl] Additional prelude. macro renaming. can(), .<> . CL elf did -e 'say 3'.

Location:

misc/elfish/on_sbcl

Files:

• EmitSBCL.pm (modified) (13 diffs)
• PrimitivesSBCL.pm (modified) (9 diffs)

misc/elfish/on_sbcl/EmitSBCL.pm

@@ -21 +21 @@
    '';
   }
-# (setq |GLOBAL::@ARGS| (new-Array (mapcar #'UP '("-v" "-e" "say 3"))))
   method prelude ($n) {
   '#|
@@ -30 +29 @@
 |#
 
-(require \'asdf)
-(require \'sb-posix)
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(pushnew #p"lib-cl/systems/" asdf:*central-registry*)
-(asdf:operate \'asdf:load-op :cl-ppcre)
+  (require \'asdf)
+  (require \'sb-posix)
 )
-
-;(declaim (optimize (debug 2)))
-
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (pushnew #p"lib-cl/systems/" asdf:*central-registry*)
+  (asdf:operate \'asdf:load-op :cl-ppcre)
+)
+
+(declaim (optimize (debug 2)))
 
 ;;------------------------------------------------------------------------------
-;; Multi-methods - avoid generic-function congruence restrictions.
+;; Generic-functions without congruence restrictions.
 ;; http://www.lispworks.com/documentation/HyperSpec/Body/07_fd.htm
 
@@ -47 +47 @@
 (defvar *maximum-number-of-dispatch-affecting-variables* 10)
 
-(defun n-variable-names (n &optional l)
-  (cond ((= 0 n) l)
-        (t (n-variable-names (1- n) (cons (gensym) l)))))
+(defun n-gensyms (n) (loop for i from 1 to n collect (gensym)))
 )
 
-(defmacro fc-old (func &rest args)
-  `(ap ,func (list ,@args)))
-
-(defmacro fc (func &rest args)
-  `(rw (fc-preserving-rw ,func ,@args)))
-
-(defmacro fc-preserving-rw (func &rest args)
+(defmacro ncgf-funcall (func &rest args)
   (let* ((n (1+ *maximum-number-of-dispatch-affecting-variables*))
          (len (length args))
-         (syms (loop for n from 1 to len collect (gensym)))
+         (syms (n-gensyms len))
          (dispatch-syms (subseq syms 0 (min n len)))
          (dispatch-padding (make-list (max 0 (- n len))))
@@ -71 +63 @@
           (funcall ,f (list ,@syms) ,@dispatch-syms ,@dispatch-padding))))))
 
-(defgeneric ap (func args))
-(defmethod ap (func args)
+(defgeneric ncgf-apply (func args))
+(defmethod ncgf-apply (func args)
   (apply func args))
-(defmethod ap ((func standard-generic-function) args)
+(defmethod ncgf-apply ((func standard-generic-function) args)
   (let* ((n (1+ *maximum-number-of-dispatch-affecting-variables*))
          (len (length args))
@@ -82 +74 @@
     (apply func (cons args dispatch-args))))
          
-(defmacro dg (name sig)
+(defmacro ncgf-defgeneric (name sig)
   (declare (ignore sig))
   (let* ((n (1+ *maximum-number-of-dispatch-affecting-variables*))
-         (vars (n-variable-names n)))
+         (vars (n-gensyms n)))
     `(defgeneric ,name (args ,@vars))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun parameters-in-lambda-list (sig)
-  (let ((pred (lambda(e) (case e
-                               (&optional t)
-                               (&rest t)
-                               ))))
-    (remove-if pred sig))) ;X should stop at &aux, etc.
+  (let ((not-param
+         (lambda(e) (case e
+                          (&optional t)
+                          (&rest t)
+                          ))))
+    (remove-if not-param sig))) ;X should stop at &aux, etc.
 )
 
-(defmacro dm (name sig &rest body)
+(defmacro ncgf-defmethod (name sig &rest body)
   (let* ((n (1+ *maximum-number-of-dispatch-affecting-variables*))
          (n-1 (1- n))
@@ -106 +99 @@
                                (gensym)
                              `(,(gensym) ,(class-of nil)))))
-         (pad-vars (n-variable-names (max 0 (- n-1 len))))
+         (pad-vars (n-gensyms (max 0 (- n-1 len))))
          (dispatch-vars (concatenate \'list real-vars bounds-var pad-vars))
          (typeless-sig (map \'list (lambda (p) (if (listp p) (car p) p)) sig))
-         )
-    `(defmethod ,name (args ,@dispatch-vars)
-       (declare (ignore ,@pad-vars))
-       (destructuring-bind ,typeless-sig args
-         ,@body))))
+         (def `(defmethod ,name (args ,@dispatch-vars)
+                 (declare (ignore ,@pad-vars))
+                 (destructuring-bind ,typeless-sig args
+                                     ,@body))))
+    def))
+
 
 ;;------------------------------------------------------------------------------
 ;; Classes
-
-(defgeneric UP (x))
 
 (defmacro pkg-init-flag-name (pkg) `(concatenate \'string ,pkg "/initialized"))
@@ -198 +190 @@
 
 ;;------------------------------------------------------------------------------
+;; can
+
+(defmacro def-can (name sig)
+  (let* ((arg0-type (cond ((not (listp (car sig))) t)
+                          (t (cadar sig))))
+         (sym (intern (concatenate \'string "CAN::" (symbol-name name)))))
+    `(defmethod ,sym ((x ,arg0-type)) nil)))
+
+(defun can-p (name obj)
+  (let* ((sym (intern (concatenate \'string "CAN::" name)))
+         (gf (symbol-function sym))
+         (argl (list obj)))
+    (if (not gf) nil
+      (if (compute-applicable-methods gf argl)
+          t nil))))
+
+;;------------------------------------------------------------------------------
+
+(defmacro fc (func &rest args)
+  `(rw (ncgf-funcall ,func ,@args)))
+
+(defmacro fc-preserving-rw (func &rest args)
+  `(ncgf-funcall ,func ,@args))
+
+(defmacro ap (func args)
+  `(ncgf-apply ,func ,args))
+
+(defmacro dm-without-can (name sig &rest body)
+  `(ncgf-defmethod ,name ,sig ,@body))
+
+(defmacro dm (name sig &rest body)
+  `(progn
+     (def-can ,name ,sig)
+     (ncgf-defmethod ,name ,sig ,@body)))
+
+;;------------------------------------------------------------------------------
 ;; Prelude & stuff
 
 ;; abbreviations
+(defgeneric UP (x))
 (defmacro S (x) `(to-s ,x))
 (defmacro N (x) `(to-n ,x))
@@ -206 +235 @@
 (defgeneric to-n (x))
 
+;; predecls
+(defclass |Any/cls| () ())
+(defclass |Bool/cls| () ())
+(defclass |Int/cls| () ())
+(defclass |Num/cls| () ())
+(defclass |Str/cls| () ())
+
+;;
 (defun set-slots (o argl)
   (let* ((clsname (symbol-name (class-name (class-of o))))
@@ -217 +254 @@
   o)
 
-(make-package "M")
-
-(defclass |Any/cls| () ())
-(defclass |Bool/cls| () ())
-(defclass |Int/cls| () ())
-(defclass |Num/cls| () ())
-(defclass |Str/cls| () ())
-
-(dg |M::new| (cls &rest argl))
-
+;;
 (dm |M::new| ((co |Any/cls|) &rest argl)
   (declare (ignorable argl))
   (set-slots (make-instance (class-of co)) argl))
 
-;; Undef is still being kludged as nil.
+(dm |M::can| (self |$method_name|)
+    (let* ((name (concatenate \'string "M::" (S |$method_name|))))
+      (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) s) (equal (S s) "Undef"))
+(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.
@@ -532 +565 @@
     my $enc_name = $.qsym('M::'~$.e($n.name));
     my $sig = $.e($n.multisig);
-    my $decl = '(eval \'(dm '~$enc_name~' ((self '~$cls~') '~$sig~' (block __f__ '~$body~')))';
+    my $decl = ('(eval \'(dm '~$enc_name~' ((self '~$cls~') '~$sig~
+                ' (declare (ignorable self))'~
+                ' (block __f__ '~$body~')))');
     $whiteboard::compunit_header.push($decl);
     "";
@@ -563 +598 @@
       if $n.plurality && $n.plurality eq 'multi' {
         my $dm_name = $.qsym('MS::'~$pkg~'::&'~$name);
-        $decl = ('(dm '~$dm_name~' '~$most~')'~"\n"~
+        $decl = ('(dm-without-can '~$dm_name~' '~$most~')'~"\n"~
                  '(defparameter '~$enc_name~' #\''~$dm_name~')');
       } else {
@@ -618 +653 @@
       $invocant = ""~$.classobject_from_package_name($invocant);
     }
-    my $call = '(fc '~$meth~' '~$invocant~' '~$.e($n.capture)~')';
+    my $e_capture = $.e($n.capture);
+    if $g = $method.re_groups('^postcircumfix:(.+)') {
+      my $op = $g[0];
+      if $op eq '< >' {
+        my $s = $n.capture.arguments[0];
+        my $words = $s.split('\s+');
+        my $self = self;
+        $e_capture = $words.map(sub($x){$self.qstr($x)}).join(" ");
+      }
+    }
+    my $call = '(fc '~$meth~' '~$invocant~' '~$e_capture~')';
     $call;
   }
@@ -696 +741 @@
       if $op eq '< >' {
         my $s = $n.capture.arguments[0];
-        my $words = $s.split(/\s+/);
-        if $words.elems == 0 {
-          return $.emit_array('');
-        } else {
-          return $.emit_array('"'~$words.join('" "')~'"');
-        }
+        my $words = $s.split('\s+');
+        my $self = self;
+        return $.emit_array($words.map(sub($x){$self.qstr($x)}).join(" "));
       }
     }

misc/elfish/on_sbcl/PrimitivesSBCL.pm

@@ -82 +82 @@
   multi slurp ($filename) is cl {'
     (with-open-file (stream (S |$filename|))
-      (let ((str (make-string (file-length stream))))
-        (read-sequence str stream)
+      (let* ((byte-length (file-length stream))
+             (buf (make-string byte-length)) ; likely too long
+             (char-length (read-sequence buf stream))
+             (str (subseq buf 0 char-length)))
         (UP str)))
   '}
@@ -119 +121 @@
       (labels
        ((undump (node)
-           (cond ((listp node)
+           (cond ((null node) (undef))
+                 ((listp node)
                   (let ((args (mapcar #\'undump (cdr node))))
                     (ecase (car node)
@@ -142 +145 @@
   }
   sub private_tidy ($s) { $s }
+  sub eval_runtime_code($code,$env) is cl {'
+    (eval (read-from-string (S |$code|)))
+  '}
+  sub file_exists ($filename) is cl {'
+    (UP (if (probe-file (S |$filename|)) t nil))
+  '}
 }
 # regexp elf bootstrap primitives
 package Str {
-  method re_matchp ($re) is cl {' (UP (ppcre::scan (S |$re|) (S self))) '}
+  method re_matchp ($re) is cl {' (UP (if (ppcre::scan (S |$re|) (S self)) t nil)) '}
   method re_groups ($re) is cl {'
     (multiple-value-bind (match_str a) (ppcre::scan-to-strings (S |$re|) (S self))
@@ -160 +169 @@
 }
 
+
 package Main {
 }
@@ -171 +181 @@
 class Undef {
 }
+
 
 class Pair {
@@ -204 +215 @@
       (setf (slot-value inst \'|Str::._native_|) (S |$s|))
       inst)
+  '}
+  method split ($pat) is cl {'
+    (let ((s (slot-value self \'|Str::._native_|)))
+      (new-Array (ppcre::split (S |$pat|) s)))
+  '}
+  method substr ($offset,$length) is cl {'
+    (let* ((s (slot-value self \'|Str::._native_|))
+           (len (length s))
+           (off (wrapped-index len (N |$offset|))))
+      (UP (subseq s off (min len (+ off (N |$length|))))))
   '}
 }
@@ -269 +290 @@
     (let* ((a (slot-value self \'|Array::._native_|)))
       (new-Array (loop for v across a collect (fc |$code| v))))
+  '}
+  method splice ($from,$to) is cl {'
+    (let* ((a (slot-value self \'|Array::._native_|))
+           (len (length a))
+           (from (wrapped-index len (N |$from|)))
+           (to (wrapped-index len (N |$to|))))
+      (new-Array (subseq a from to)))
+  '}
+  method reverse () is cl {'
+    (let* ((a (slot-value self \'|Array::._native_|)))
+      (new-Array (reverse a)))
   '}
 }
@@ -290 +322 @@
       inst)
   '}
+  method dup () is cl {'
+    (let ((hk (slot-value self \'|Hash::._keys_|))
+          (hv (slot-value self \'|Hash::._values_|))
+          (hk2 (make-hash-table :test #\'equal))
+          (hv2 (make-hash-table :test #\'equal))
+          (inst (make-instance \'|Hash/cls|)))
+      (setf (slot-value inst \'|Hash::._keys_|) hk)
+      (setf (slot-value inst \'|Hash::._values_|) hv)
+      (maphash #\'(lambda (k v) (setf (gethash k hk2) v)) hk)
+      (maphash #\'(lambda (k v) (setf (gethash k hv2) v)) hv)
+      inst)
+  '}
 
   method kv () is cl {'
@@ -368 +412 @@
 class Str   { method Num () { self.primitive_Num() } }
 class Array { method Num () { self.elems } }
-class Hash  { method Num () { self.keys.elems } }
+class Hash  { method Num () { self.keys.elems } } ;#X hash-table-count
 class Pair  { method Num () { 2 } }