additions and corrections in connection with spocq sae development.

remove implicity prerequisute loading leaving it instead to explicit build process.

bsd:
 added getpid, syslog

codecs/etf :
 generalize the transformation hooks to allow sse/bert/etf layered codecs;
 add interface operators encode/decode-bert-term

lock :
 make-weak-hash-table

mime/ :
 add binary abstract type to support stream-reader/writer distinctions

test/rspec/ :
 further rspec.rd -> sbcl testing; add specials for streams

Author: lisp

bsd/bsd.lisp

@@ -61,6 +61,7 @@
   (:use :common-lisp :ccl)
   (:nicknames :bsd)
   (:export :*run-command-eol*
+           :closelog
            :gethostname
            :popen
            :pclose
@@ -71,14 +72,17 @@
            :file-bsd-namestring
            :file-mac-namestring
            :getenv
+           :getpid
+           :openlog
            :pipe-input-stream
            :pipe-io-stream
            :pipe-output-stream
+           :syslog
            :with-popen)
   (:documentation
    "The `:de.setf.utility.bsd` library component implements low-level support for a limited number
  of 'Berkeley' UNIX library primitive operators:
- - getenv
+ - getenv, getpid
  - gethostname
  - popen
  - pclose
@@ -144,6 +148,10 @@
 ;;; FFI
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (deftrap-inline "_closelog"
+    ()
+    nil
+    ())
   (deftrap-inline "_feof"
     ((file-pointer :pointer))
     :signed-word
@@ -166,11 +174,21 @@
     ((string :pointer))
     :pointer
     ())
+  (deftrap-inline "_getpid"
+    ()
+    :unsigned-word
+    ())
   (deftrap-inline "_gethostname"
     ((returnArg :pointer)
      (length :unsigned-long))
     :unsigned-long
     ())
+  (deftrap-inline "_openlog"
+    ((string :pointer)
+     (options :unsigned-word)
+     (facility :unsigned-word))
+    ()
+    ())
   (deftrap-inline "_pclose"
     ((file :pointer))
     :signed-word
@@ -179,6 +197,12 @@
     ((command :pointer)
      (mode :pointer))
     :pointer
+    ())
+  (deftrap-inline "_syslog"
+    ((priority :unsigned-word)
+     (format :pointer)
+     (message :pointer))
+    ()
     ()))
 
 
@@ -188,6 +212,9 @@
       (unless (ccl:%null-ptr-p %value)
         (ccl:%get-cstring %value)))))
 
+(defun bsd:getpid ()
+  (#_getpid))
+
 
 (defun bsd:gethostname ()
   "Return the system hostname as a string.
@@ -291,6 +318,37 @@
       (#_fwrite %buffer length 1 %file))))
 
 
+;;; syslog
+;;;
+;;; facility
+(defparameter log-user (ash 1 3))
+(defparameter log-daemon (ash 3 3))
+
+;;; level
+(defparameter log-emerg 0)
+(defparameter log-alert 1)
+(defparameter log-crit 2)
+(defparameter log-err 3)
+(defparameter log-warning 4)
+(defparameter log-notice 5)
+(defparameter log-info 6)
+(defparameter log-debug 7)
+
+;;; interface
+(defun closelog ()
+  (#_closelog))
+
+(defun openlog (identity options &optional (facility log-user))
+  (ccl:with-cstrs ((%identity identity))
+    (#_openlog %identity options facility)))
+
+(defun syslog (priority format &rest args)
+  (ccl:with-cstrs ((%format (apply #'format nil format args))
+                   (%cformat "%s"))
+    (#_syslog priority %cformat %format)))
+
+;;; external commands
+
 (defun bsd:run-command (program &rest args)
   "run a unix command and return the standard output as a string.
 

build-init.lisp

@@ -35,6 +35,7 @@
       *load-truename*
       *default-pathname-defaults*
       (error "Indeterminate load pathname...")))
+
 (setq *build-init-pathname* (truename *build-init-pathname*))
 
 (when *load-verbose*
@@ -44,6 +45,16 @@
 ;;; load the production asdf version for building images
 ;;; in a dev tree, this mens to go upwards to look for the production tree
 
+(defun compile-and-load-file (source-pathname)
+  (let ((binary-pathname (compile-file-pathname source-pathname)))
+    (if (probe-file binary-pathname)
+      (if (probe-file source-pathname)
+        (if (> (file-write-date binary-pathname) (file-write-date source-pathname))
+          (load binary-pathname)
+          (load (compile-file source-pathname)))
+        (load binary-pathname))
+      (load (compile-file source-pathname)))))
+
 (defparameter *asdf-pathname*
   (make-pathname :directory (append (pathname-directory *build-init-pathname*)
                                     '("net" "common-lisp" "asdf"))
@@ -55,26 +66,46 @@
   (cond ((probe-file *asdf-pathname*)
          (when *load-verbose*
            (format *trace-output* "~&;Incorporating asdf anew from ~s." *asdf-pathname*))
-         (load (compile-file *asdf-pathname*))
+         (compile-and-load-file *asdf-pathname*)
          #+ecl
-         (load (compile-file (make-pathname :name "asdf-ecl" :defaults *asdf-pathname*))))
+         (compile-and-load-file (make-pathname :name "asdf-ecl" :defaults *asdf-pathname*)))
         (t
          (cerror "Continue anyway." "ASDF is missing: ~s." *asdf-pathname*))))
 
 
 ;;;
 ;;; incorporate support for hierarchical names
-#+(or :clozure :allegro sbcl) ;; for now
+
+#+(or :clozure :allegro :sbcl) ;; for now
 (unless (fboundp (find-symbol (string :sysdef-hierarchical-search-function) :asdf))
-  (loop for (path name) in '((("de" "setf" "utility") "pathnames")
+  (loop for (path name) in '((("de" "setf" "utility") "package")
+                             (("de" "setf" "utility") "pathnames")
                              (("de" "setf" "utility" "asdf") "hierarchical-names"))
         do (let ((pathname (make-pathname :directory (append (pathname-directory *build-init-pathname*) path)
                                           :name name :type "lisp"
                                           :defaults *build-init-pathname*)))
              (if (probe-file pathname)
-               (load pathname)
+               (compile-and-load-file pathname)
                (cerror "Continue anyway." "Hierarchical name component is missing: ~s." pathname)))))
 
+;;;
+;;; define logical hosts for the dev sources and, optionally, production sources
+
+(or (ignore-errors (logical-pathname-translations "LIBRARY"))
+    (de.setf.utility:define-library-host *build-init-pathname* "LIBRARY"))
+
+;; nb. clisp neither merges :up relative pathnames, nor (by default) correctly parses logical namestrings
+(or (ignore-errors (logical-pathname-translations "P-LIBRARY"))
+    (let* ((library (truename (make-pathname :host "LIBRARY" :directory '(:absolute))))
+           (production (make-pathname :directory (substitute "production" "dev"
+                                                             (pathname-directory *build-init-pathname*)
+                                                             :test #'string-equal)
+                                      :name nil :type nil :defaults *build-init-pathname*)))
+      (when (and (#-clisp probe-file #+clisp ext:probe-directory production)
+                 (not (equalp production library)))
+        (de.setf.utility:define-library-host production "P-LIBRARY"))))
+
+
 
 ;;;
 ;;; augment the asdf central registry.
@@ -87,7 +118,7 @@
          (when (#-clisp probe-file #+clisp probe-directory pathname)
            (pushnew (truename pathname) asdf:*central-registry* :test #'equalp)))
      (list (make-pathname :directory (append (pathname-directory *build-init-pathname*)
-                                          '("asdf-registry"))
+                                             '("asdf-registry"))
                           :defaults *build-init-pathname*)
            *build-init-pathname*))