Moved scat to utility.

Pascal J. Bourguignon [2018-12-30 19:28]
Moved scat to utility.
Filename
clext/association.lisp
clext/pkcs11/pkcs11.lisp
common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
common-lisp/cesarum/string.lisp
common-lisp/cesarum/utility-test.lisp
rdp/packages.lisp
rdp/rdp.lisp
diff --git a/clext/association.lisp b/clext/association.lisp
index 1b73031..c35a1e7 100644
--- a/clext/association.lisp
+++ b/clext/association.lisp
@@ -36,6 +36,7 @@
   (setf *readtable* (copy-readtable nil)))
 (defpackage "COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
   (:use "COMMON-LISP" "CLOSER-MOP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SYMBOL" "SCAT")
   (:shadowing-import-from "CLOSER-MOP"
                           "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD"
                           "DEFMETHOD" "DEFGENERIC")
@@ -531,11 +532,6 @@ RETURN:        MIN; MAX"
     class))


-(defun scat (&rest string-designators)
-  (intern (apply (function concatenate) 'string
-                 (mapcar (function string) string-designators))))
-
-
 ;; (defmacro define-association (name ((role &key type slot accessor
 ;;                                           multiplicity implementation
 ;;                                           multiple ordered qualifier
diff --git a/clext/pkcs11/pkcs11.lisp b/clext/pkcs11/pkcs11.lisp
index c50a4e3..e822b85 100644
--- a/clext/pkcs11/pkcs11.lisp
+++ b/clext/pkcs11/pkcs11.lisp
@@ -35,6 +35,7 @@
 (defpackage "COM.INFORMATIMAGO.CLEXT.PKCS11"
   (:use "COMMON-LISP" "CFFI" "BABEL")
   (:use "COM.INFORMATIMAGO.CLEXT.PKCS11.CFFI-UTILS")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SYMBOL" "SCAT")
   (:import-from "COM.INFORMATIMAGO.CLEXT.PKCS11.LOW" "LOAD-LIBRARY")
   (:shadowing-import-from "COM.INFORMATIMAGO.CLEXT.PKCS11.CFFI-DEBUG"
                           "FOREIGN-ALLOC" "FOREIGN-FREE")
@@ -1944,10 +1945,6 @@ RETURN: TEMPLATE
        (set-mechanism fmechanism mechanism)
        (check-rv (,low-name session fmechanism ,@(when keyp `(key))) ,c-name))))

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun scat (&rest args)
-    (intern (reduce (lambda (a b) (concatenate 'string a b)) args :key (function string)))))
-
 (defmacro define-pkcs11-processing-function (name low-name c-name &key (input '()) (outputp t))
   "Defines a function to process buffers.

diff --git a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
index 4e2c598..d62c4b4 100644
--- a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
+++ b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.asd
@@ -11,6 +11,7 @@
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
+;;;;    2018-12-30 <PJB> Added symbol.lisp
 ;;;;    2010-10-31 <PJB> Created this .asd file.
 ;;;;BUGS
 ;;;;LEGAL
@@ -63,7 +64,7 @@ all written in 100% conforming Common Lisp.
   :licence "AGPL3"
   ;; component attributes:

-  :version "1.8.0"
+  :version "1.8.1"
   :properties ((#:author-email                   . "pjb@informatimago.com")
                (#:date                           . "Autumn 2015")
                ((#:albert #:output-dir)          . "/tmp/documentation/com.informatimago.common-lisp.cesarum/")
@@ -82,7 +83,8 @@ all written in 100% conforming Common Lisp.
                (:file "array"           :depends-on ())
                (:file "sequence"        :depends-on ())
                (:file "list"            :depends-on ())
-               (:file "utility"         :depends-on ("list"))
+               (:file "symbol"          :depends-on ())
+               (:file "utility"         :depends-on ("list" "symbol"))
                (:file "string"          :depends-on ("utility" "list" "sequence" "ecma048"))
                (:file "package"         :depends-on ("utility"))

diff --git a/common-lisp/cesarum/string.lisp b/common-lisp/cesarum/string.lisp
index 02f6d34..a583889 100644
--- a/common-lisp/cesarum/string.lisp
+++ b/common-lisp/cesarum/string.lisp
@@ -277,9 +277,6 @@ NOTE:    Unfortunately some implementations don't take into account
                          ((>= i max) result)
                        (setf (char result i) (character (aref ,seq i)))))) )))

-
-
-
 (defgeneric explode (object &optional result-type)
   (:documentation "
 RETURN:         A sequence of character of type RESULT-TYPE containing
@@ -297,7 +294,6 @@ OBJECT:         Can be a string, a symbol (its symbol-name is exploded),
   (:method ((object t) &optional (result-type 'list))
     (explode-string (prin1-to-string object) result-type)))

-
 (defun implode (char-seq &optional (result-type 'symbol) (package *package*))
   "
 RETURN:         An object of type RESULT-TYPE made with the character
@@ -318,7 +314,6 @@ PACKAGE:        When RESULT-TYPE is SYMBOL, then the package where the
                           object (type-of object) result-type)
                   object))))

-
 (defun split-escaped-string (string-designator escape separator)
   "
 STRING-DESIGNATOR:  A string designator.
diff --git a/common-lisp/cesarum/utility-test.lisp b/common-lisp/cesarum/utility-test.lisp
new file mode 100644
index 0000000..0598f58
--- /dev/null
+++ b/common-lisp/cesarum/utility-test.lisp
@@ -0,0 +1,128 @@
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
+
+(defun test/get-option ()
+  (mapc (lambda (expected-arguments)
+          (destructuring-bind (expected arguments) expected-arguments
+            (handler-case
+                (let ((result (apply (function get-option) arguments)))
+                  (if (equal expected result)
+                      result
+                      (error "For ~S, expected ~S, got ~S" (cons 'get-option arguments) expected result)))
+              (error (err)
+                (if (eql expected 'error)
+                    err
+                    (error "For ~S, expected ~S, got ~S" (cons 'get-option arguments) expected err))))))
+        '((nil                         (:foo (:bar (:quux))))
+          (nil                         (:foo (:bar (:quux))           :list))
+          (:symbol                     (:foo (:bar :foo (:quux))))
+          (error                       (:foo (:bar :foo (:quux) :foo)))
+          (:singleton                  (:foo (:bar (:foo) (:quux))))
+          ((nil)                       (:foo (:bar (:foo nil) (:quux))))
+          ((foo)                       (:foo (:bar (:foo foo) (:quux))))
+          ((foo bar baz)               (:foo (:bar (:foo foo bar baz) (:quux))))
+          ((:foo)                      (:foo (:bar :foo (:quux))                   :list))
+          ((:foo :foo)                 (:foo (:bar :foo (:quux) :foo)              :list))
+          (((:foo) :foo (:foo foo))    (:foo (:bar (:foo) (:quux) :foo (:foo foo)) :list))))
+  :success)
+
+(defun test/all ()
+  (test/get-option))
+
+
+(mapcar
+ (lambda (expected-arguments)
+   (destructuring-bind (expected arguments) expected-arguments
+     (handler-case
+         (let ((results (multiple-value-list
+                         (apply (function parse-structure-name-and-options) arguments))))
+           results
+           #-(and)
+           (if (equal expected results)
+               results
+               (error "For ~S, expected ~S, got ~S" (cons 'parse-structure-name-and-options arguments) expected results)))
+       (error (err)
+         (if (eql expected 'error)
+             err
+             (error "For ~S, expected ~S, got ~S" (cons 'parse-structure-name-and-options arguments) expected err))))))
+ '(
+   (()  (point))
+   ))
+
+(assert
+ (equalp
+  (mapcar (lambda (arguments)
+            (print
+             (mapcan (function list)
+                     '(:name :conc-name :constructors :copier :include :initial-offset :predicate :print-function :print-object :structure-type-p :structure-type)
+                     (multiple-value-list (apply (function parse-structure-name-and-options) arguments)))))
+          '((point)
+            ((point))
+            ((point :conc-name))
+            ((point (:conc-name)))
+            ((point (:conc-name nil)))
+            ((point (:conc-name pt-)))
+            ((point :copier))
+            ((point (:copier)))
+            ((point (:copier nil)))
+            ((point (:copier copy-pt)))
+
+            ((point :conc-name  :copier))
+            ((point (:conc-name) (:copier)))
+            ((point (:conc-name nil) (:copier nil)))
+            ((point (:conc-name pt-)  (:copy copy-pt)))
+
+            ((point :constructor))
+            ((point (:constructor)))
+            ((point (:constructor nil)))
+            ((point (:constructor %make-pt)))
+            ((point :constructor (:constructor %make-pt) (:constructor %make-a-pt (x y))))
+            ((point (:print-function)))
+            ((point (:print-function nil)))
+            ((point (:print-function print-pt)))
+            ((point :print-object))
+            ((point (:print-object)))
+            ((point (:print-object nil)))
+            ((point (:print-object print-pt)))
+            ))
+
+  '((:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name pt- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier nil :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-pt :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name || :constructors (make-point) :copier nil :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name pt- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors nil :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (%make-pt) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point %make-pt (%make-a-pt (x y))) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function print-pt :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object nil :structure-type-p nil :structure-type nil)
+    (:name point :conc-name point- :constructors (make-point) :copier copy-point :include nil :initial-offset nil :predicate point-p :print-function nil :print-object print-pt :structure-type-p nil :structure-type nil))))
+
+
+#-(and)
+(progn
+  (pprint (macroexpand-1 '(define-structure-class point x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point :conc-name) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:conc-name)) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:conc-name nil)) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:conc-name pt-)) x y)))
+
+  (pprint (macroexpand-1 '(define-structure-class (point :predicate) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:predicate)) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:predicate nil)) x y)))
+  (pprint (macroexpand-1 '(define-structure-class (point (:predicate ptp)) x y)))
+  )
diff --git a/rdp/packages.lisp b/rdp/packages.lisp
index f1b3215..e17923d 100644
--- a/rdp/packages.lisp
+++ b/rdp/packages.lisp
@@ -43,8 +43,8 @@
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST"
         "COM.INFORMATIMAGO.COMMON-LISP.REGEXP.REGEXP"
         "COM.INFORMATIMAGO.COMMON-LISP.PARSER.SCANNER"
-        "COM.INFORMATIMAGO.COMMON-LISP.PARSER.PARSER"
-        )
+        "COM.INFORMATIMAGO.COMMON-LISP.PARSER.PARSER")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SYMBOL" "SCAT")
   (:export "DEFGRAMMAR" "-->" "SEQ" "REP" "OPT" "ALT" "GRAMMAR-NAMED"
            "GENERATE-GRAMMAR"

diff --git a/rdp/rdp.lisp b/rdp/rdp.lisp
index 82c90ef..ed793d1 100644
--- a/rdp/rdp.lisp
+++ b/rdp/rdp.lisp
@@ -302,10 +302,7 @@ RETURN:     A form that defines the grammar object and its parser functions.
 ;;; Utilities
 ;;;

-(defun scat (&rest string-designators)
-  "Interns the concatenation of the STRING-DESIGNATORS."
-  (intern (apply (function concatenate) 'string
-                 (mapcar (function string) string-designators))))
+
 (defun dollar (n)
   "Interns a $-symbol number N."
   (scat "$" (prin1-to-string n)))
ViewGit