Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp

Pascal J. Bourguignon [2013-06-22 14:10]
Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp
Filename
clext/closer-weak.lisp
common-lisp/cesarum/string.lisp
common-lisp/telnet/status.lisp
common-lisp/telnet/telnet.lisp
languages/linc/linc.lisp
languages/lua/lua-scanner.lisp
diff --git a/clext/closer-weak.lisp b/clext/closer-weak.lisp
index cca9560..94fa5b5 100644
--- a/clext/closer-weak.lisp
+++ b/clext/closer-weak.lisp
@@ -758,6 +758,24 @@ It has no effect when some key has already been garbage-collected.")
 ;;;---------------------------------------------------------------------
 ;;; Weak Hash Tables

+
+#-(and (or ccl clisp) (not debug-weak))
+(defgeneric %gethash (key self &optional default)
+  (:method (key (self t) &optional default)
+    (common-lisp:gethash key self default)))
+#-(and (or ccl clisp) (not debug-weak))
+(defgeneric (setf %gethash) (value key self &optional default)
+  (:method (value key (self t) &optional default)
+    (setf (common-lisp:gethash key self default) value)))
+#-(and (or ccl clisp) (not debug-weak))
+(defgeneric %remhash (key self)
+  (:method (key (self t)) (common-lisp:remhash key self)))
+#-(and (or ccl clisp) (not debug-weak))
+(defgeneric %maphash (function self)
+  (:method (function (self t)) (common-lisp:maphash function self)))
+#-(and (or ccl clisp) (not debug-weak))
+(defgeneric %clrhash (self)
+  (:method ((self t)) (common-lisp:clrhash self)))

 #-(and (or ccl clisp) (not debug-weak))
 (defclass weak-hash-table ()
@@ -1062,39 +1080,22 @@ It has no effect when some key has already been garbage-collected.")


 #-(and (or ccl clisp) (not debug-weak))
-(defgeneric %gethash (key self &optional default)
-  (:method (key (self t) &optional default)
-    (common-lisp:gethash key self default)))
-#-(and (or ccl clisp) (not debug-weak))
 (defun gethash (key hash-table &optional default)
   (%gethash key hash-table default))

-#-(and (or ccl clisp) (not debug-weak))
-(defgeneric (setf %gethash) (value key self &optional default)
-  (:method (value key (self t) &optional default)
-    (setf (common-lisp:gethash key self default) value)))
+
 #-(and (or ccl clisp) (not debug-weak))
 (defun (setf gethash) (value key hash-table &optional default)
   (setf  (%gethash key hash-table default) value))


 #-(and (or ccl clisp) (not debug-weak))
-(defgeneric %remhash (key self)
-  (:method (key (self t)) (common-lisp:remhash key self)))
-#-(and (or ccl clisp) (not debug-weak))
 (defun remhash (key hash-table) (%remhash key hash-table))

 #-(and (or ccl clisp) (not debug-weak))
-(defgeneric %maphash (function self)
-  (:method (function (self t)) (common-lisp:maphash function self)))
-#-(and (or ccl clisp) (not debug-weak))
 (defun maphash (function hash-table) (%maphash function hash-table))


-
-#-(and (or ccl clisp) (not debug-weak))
-(defgeneric %clrhash (self)
-  (:method ((self t)) (common-lisp:clrhash self)))
 #-(and (or ccl clisp) (not debug-weak))
 (defun clrhash (hash-table) (%clrhash hash-table))

diff --git a/common-lisp/cesarum/string.lisp b/common-lisp/cesarum/string.lisp
index f1b557c..6af9c2e 100644
--- a/common-lisp/cesarum/string.lisp
+++ b/common-lisp/cesarum/string.lisp
@@ -167,6 +167,7 @@ RESULT-TYPE:    A sequence type accepted by MAP.  Default: LIST.
   "
 RETURN: A new string containing the characters in the sequence CHAR-SEQ.
 "
+  (check-type char-seq sequence)
   (map 'string (function character) char-seq))


diff --git a/common-lisp/telnet/status.lisp b/common-lisp/telnet/status.lisp
index 1d1e796..577f52f 100644
--- a/common-lisp/telnet/status.lisp
+++ b/common-lisp/telnet/status.lisp
@@ -70,6 +70,9 @@ or:

 "))

+(defgeneric send-status-request (status nvt))
+(defgeneric send-status (status nvt))
+(defgeneric receive-status (status nvt bytes &key start end))

 (defmethod send-status-request ((opt status) nvt)
   "Send a STATUS SEND message."
diff --git a/common-lisp/telnet/telnet.lisp b/common-lisp/telnet/telnet.lisp
index 7ecf465..c949c43 100644
--- a/common-lisp/telnet/telnet.lisp
+++ b/common-lisp/telnet/telnet.lisp
@@ -844,6 +844,8 @@ accompanied by a TCP Urgent notification.")
    (himq :initform :empty :type side-option-queue
          :accessor opt-himq)))

+(defgeneric option-name (option))
+
 (defmethod option-name ((opt option))
   "RETURN: The option name if it has one, otherwise the option code."
   (if (slot-boundp opt 'name)
@@ -1212,6 +1214,9 @@ Bytes received from down, waiting to be parsed by the local NVT.")
 and are discarding text bytes till the next IAC DM."))
   (:documentation "Represents a telnet end-point (both 'client' and 'server')."))

+(defgeneric init-option-name (nvt option-name))
+(defgeneric init-option-code (nvt option-code &optional option-name))
+(defgeneric get-option (nvt option-name))

 (defmethod print-object ((self network-virtual-terminal) stream)
   (print-unreadable-object (self stream :identity t :type t)
@@ -1221,6 +1226,7 @@ and are discarding text bytes till the next IAC DM."))
             (nvt-send-wait-p self)))
   self)

+(defgeneric nvt-options (nvt))

 (defmethod nvt-options ((nvt network-virtual-terminal))
   "RETURN: A fresh list of the current OPTION instance in the NVT."
@@ -1254,6 +1260,8 @@ and are discarding text bytes till the next IAC DM."))
 ;; TODO: When LINE-MODE we should keep in a buffer until an end of
 ;;       record (CRLF, EOR, FORW1 FORW2, etc) is sent.  On the other
 ;;       hand, this may be done by the terminal layer itself?
+(defgeneric send-raw-bytes  (nvt  bytes))
+(defgeneric send-urgent-notification  (nvt))

 (defmethod send-raw-bytes  ((nvt network-virtual-terminal) bytes)
   "Send the binary bytes.
@@ -1334,6 +1342,8 @@ CONTROL: (member :synch :are-you-there :abort-output :interrupt-process :go-ahea

 ;; Down interface (from down):

+(defgeneric receive-urgent-notification (nvt))
+
 (defmethod receive-urgent-notification ((nvt network-virtual-terminal))
   (setf (urgent-mode-p nvt) t))

@@ -1581,7 +1591,7 @@ NEXT:   the index of the first unprocessed byte. (<= START NEXT END)
     (#.CR  :cr)
     (otherwise nil)))

-
+(defgeneric dispatch-message (nvt bytes start end))
 (defmethod dispatch-message ((nvt network-virtual-terminal) bytes start end)
   "
 RETURN: the length of bytes processed.
@@ -1791,7 +1801,6 @@ BUFFER: An adjustable vector with a fill-pointer.
        (setf (gethash option-code (slot-value nvt 'options))
              (make-option option-code option-name))))))

-
 (defmethod init-option-name ((nvt network-virtual-terminal) option-name)
   (let ((code (option-code-for-name option-name)))
     (if code
diff --git a/languages/linc/linc.lisp b/languages/linc/linc.lisp
index 04efb72..719dcd1 100644
--- a/languages/linc/linc.lisp
+++ b/languages/linc/linc.lisp
@@ -808,7 +808,6 @@ RETURN:  A destructuring-lambda-list; a literal a-list ; a variable a-list.
 ;; enum { blue=1, white, red } colors;


-(defgeneric generate (expression))

 (defun generate-type (expression &key name)

@@ -818,26 +817,26 @@ RETURN:  A destructuring-lambda-list; a literal a-list ; a variable a-list.
      (emit (format nil "~(~A~)" (first expression)))
      (cond
        ((listp (second expression))
-        ;; (class (superclass...) :public|:protected|:private member...)
-        ;; superclass ::= (classname [:virtual] [:public|:protected|:private])
-        ;; superclass ::= classname
-
         (when name
           (emit " ")
           (generate name))
+
+        ;; (class (superclass...) :public|:protected|:private member...)
+        ;; superclass ::= (classname [:virtual] [:public|:protected|:private])
+        ;; superclass ::= classname
+
         (when (second expression)
           (emit ":")
           (generate-list ","
                          (lambda (superclass)
                              (if (listp superclass)
-                               (case (length item)
-                                 ((1) (generate (first item)))
+                               (case (length superclass)
+                                 ((1) (generate (first superclass)))
                                  ((2 3)
-                                  (emit (format nil "~(~{~A~^ ~}~)" (rest item)))
-                                  (generate (first item)))
+                                  (emit (format nil "~(~{~A~^ ~}~)" (rest superclass)))
+                                  (generate (first superclass)))
                                  (otherwise
-                                  (error "Invalid syntax for a superclass: ~S"
-                                         superclass)))
+                                  (error "Invalid syntax for a superclass: ~S" superclass)))
                                (generate superclass)))
                          (second expression)))
         (emit :fresh-line)
@@ -846,8 +845,8 @@ RETURN:  A destructuring-lambda-list; a literal a-list ; a variable a-list.
             (if (member member '(:public :protected :private))
               (emit :fresh-line (format nil "~(~A~):" member) :newline)
               (generate member)))))
-       (progn
-         (emit ))))
+       (t
+        (error "Not implemented yet, generation of type ~S" expression))))

     ((com.informatimago.linc.c::enum)
      ;; (enum (blue 1) white red (yellow 10))
@@ -866,10 +865,7 @@ RETURN:  A destructuring-lambda-list; a literal a-list ; a variable a-list.
              (otherwise
               (error "Invalid syntax for an enum constant: ~S" item)))
            (generate item))
-         (emit "," :newline))))
-
-
-    ))
+         (emit "," :newline))))))


 (defun generate-declaration (?declaration)
@@ -1060,17 +1056,18 @@ RETURN:  A destructuring-lambda-list; a literal a-list ; a variable a-list.
       (case (first expression)

         ((\#cond)
-         (let ((op "#if"))
+         (let ((op "#if")
+               (clauses (rest expression)))
            (dolist (clause clauses)
              (destructuring-bind (condi &rest body) clause
-              (if (find condi '(t (quote t)) :test (function equal))
-                  (emit :fresh-line "#else" :newline)
-                  (progn (emit :fresh-line op " ")
-                         (generate-expression condi)
-                         (emit :newline)
-                         (setf op "#elif")))
-              (dolist (item body)
-                (generate item))))))
+               (if (find condi '(t (quote t)) :test (function equal))
+                   (emit :fresh-line "#else" :newline)
+                   (progn (emit :fresh-line op " ")
+                          (generate-expression condi)
+                          (emit :newline)
+                          (setf op "#elif")))
+               (dolist (item body)
+                 (generate item))))))

         ((\#if \#ifdef \#ifndef)
          (destructuring-bind (\#test ?condition ?then &optional ?else) expression
diff --git a/languages/lua/lua-scanner.lisp b/languages/lua/lua-scanner.lisp
index dabba1b..502d1a9 100644
--- a/languages/lua/lua-scanner.lisp
+++ b/languages/lua/lua-scanner.lisp
@@ -126,6 +126,11 @@
 when NIL, comments are skipped as spaces."))
   (:documentation "A scanner for LUA."))

+(defgeneric process-escape (scanner  text value))
+(defgeneric scan-string-starting-with (scanner delimiter))
+(defgeneric scan-string-starting-with-long-bracket (scanner bracket))
+(defgeneric scan-identifier (scanner))
+(defgeneric scan-number (scanner))

 (defmethod process-escape ((scanner lua-scanner) text value)
   (let ((ch (getchar scanner)))
@@ -239,6 +244,7 @@ when NIL, comments are skipped as spaces."))
     (values text value)))


+
 (defmethod scan-string-starting-with-long-bracket ((scanner lua-scanner) bracket)
   (let (text value)
     (setf text
ViewGit