mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 07:30:55 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove old, unused contributed files.

Browse source
This commit is contained in:
jjgarcia 2005-02-14 14:37:10 +00:00
parent 0f9cd17271
commit 097cc08c1c
13 changed files with 0 additions and 11789 deletions
Download patch file Download diff file Expand all files Collapse all files

1951
contrib/logical-pathnames.ecl
View file

File diff suppressed because it is too large Load diff

2000
contrib/logical-pathnames.lsp
View file

File diff suppressed because it is too large Load diff

2730
contrib/make.lsp
View file

File diff suppressed because it is too large Load diff

347
contrib/metering.lsp
View file

@ -1,347 +0,0 @@
From daemon Fri Jul 8 22:43:26 1994
>From clisp-list@ma2s2.mathematik.uni-karlsruhe.de Fri Jul 8 22:43:16 1994
Return-Path: <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Date: Fri, 8 Jul 94 22:45:40 +0200
Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de
Originator: clisp-list@ma2s2.mathematik.uni-karlsruhe.de
Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de
Reply-To: clisp-list <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Sender: clisp-list@ma2s2.mathematik.uni-karlsruhe.de
Version: 5.5 -- Copyright (c) 1991/92, Anastasios Kotsikonas
From: donc@ISI.EDU (Don Cohen)
To: Multiple recipients of list <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Subject: recording function calls
From: "Edward G. Kovach" <kovach@franus.edu>
Is there a way to ... get a listing of..
A. How many times a particular function is called?
B. How much time it takes to run each function?
I've seen several such facilities. The one I like, though, is
my own, included below. At the cost of some extra space, it
records not only the number of calls and total time, but each
individual call, its inputs and outputs, its start/finish time.
This is much more useful for debugging and tuning, since you get
to see WHICH calls took a lot of time, which ones got the wrong
inputs or computed the wrong results, etc.
;;; -*- Mode: LISP; Package: USER; Syntax: Common-lisp -*-
(lisp::in-package "USER")
; ---- Record the calls to given functions ----
#| 2/17/89 - try to avoid advice, not so much because it's not commonlisp
as because it's not compiled! In fact, I want to be able to turn on and
off recording at high frequency and encapsulations seem to get in the way
of this. For now I'll assume that one does not encapsulate and record the
same functions.
In order to monitor a function one first prepares it for monitoring, then
one can turn monitoring on and off at high frequency. One can also reset
or read the monitoring data for a function. Finally one can forget about
monitoring a function.
*monitored-fns* is a list of functions currently prepared for monitoring.
(prepare-record-calls '(f1 f2 f3)) prepares the functions named.
additional keyword arguments: entryforms, exitforms, test
The entryforms are evaluated at function entry, the exitforms at function
exit. The results are recorded along with inputs, outputs, entry time
and exit time. Test is a form (default is T) that determines whether
this particular call will be recorded. It runs in an environment where
ARGS is bound to the argument list of the function.
(record-on '(f1 f2 f3)) turns on recording for these functions.
(record-off '(f1 f2 f3)) turns it off.
(initialize-records '(f1 f2 f3)) discards all monitoring data for the
functions (but does not turn recording off or on and does not forget
preparation).
(recorded-calls 'f1) returns a list of the call records for f1.
This is a list of records of the form
(inputs outputs start-time1 start-time2 end-time1 end-time2
<values of entry forms> <values of exit forms>)
Times are represented as 2 numbers since some clocks wrap around.
The second is a wrap around count that is incremented whenever the
finish time comes out lower than the start time.
(summarize-calls '(f1 f2 f3)) prints a summary of the calls.
The argument defaults to *monitored-fns*.
Additional optional argument: name-alist
Name-alist is something like ((f1 . "updating database") (f2 . "waiting"))
and is used to translate function names into something more meaningful.
(forget-record-calls '(f1 f2 f3)) discards all monitoring data and preparation
(longest-n-calls 'f2 3) lists the 3 longest recorded calls of f2
additional keyword arguments: start end filterfn
filterfn - a function of 1 arg (inputs outputs start finish)
should return T if the call is "interesting"
start/end are special cases - filter out anything that starts before start
or ends after end
(time-line '(f1 f2 f3) produces a time line of activity
additional keyword arguments: (width 80) filterfn start end name-alist
Both symbolics and TI have a fast short clock and a slow long one.
We use the fast one on symbolics, slow one on TI.
time before wrap around / #usec to read clock
--------------------------------------------
symbolics 3600 TI explorer II
fast >.5 hour / 67 * 16 sec. / 260
slow >100 yrs / 218 >1 hour / 260 *
Actually we notice wrap around and record it - whenever a clock access
returns a smaller value than the previous one we increment a counter.
Therefore all events are ordered correctly, but if you fail to read the
clock for an hour or so, it's as if that time never passed. This is bad
if you time things on such a coarse scale, but good if you time one thing
for a minute today and something else for a minute tomorrow - the time
line between such events never separates them by much more than an hour.
In practice I don't think this will matter much.
Since calls are recorded by pushing onto a list at exit, they are ordered
by decreasing exit time. This is handy for finding the outermost calls
in the case where the calls all come from the same process (and must thus
be properly nested).
(outermost (recorded-calls 'foo))
returns the subset of the calls to foo that are outermost.
|#
(defvar *monitored-fns* nil)
(defvar *clock-cycle* 0)
(defvar *last-time* 0)
(defun prepare-record-calls (fns &key entryforms exitforms (test t))
(loop for fn in fns do (prepare-record-call fn entryforms exitforms test)))
; record-calls-fn prop is cons substitute and original fns
(defun prepare-record-call (fn entryforms exitforms test &aux prop)
(cond ((not (fboundp fn)) (error "no such function as ~A" fn))
#+zetalisp
((and (si:function-encapsulated-p fn)
(warn "~A is an encapsulation") nil))
#+ignore ; might be called with different entryforms/exitforms
((and (setf prop (get fn 'record-calls-fn))
(eq (cdr prop) (symbol-function fn)))
#+ignore (warn "~A already recorded" fn))
((eq (symbol-function fn) (car prop))
#+ignore (warn "~A already prepared" fn))
(t ; not cached ...
(setf (get fn 'record-calls-fn)
(cons (make-record-fn fn entryforms exitforms test)
(symbol-function fn)))
(pushnew fn *monitored-fns*))))
(defun make-record-fn (fn entryforms exitforms test)
(compile nil
`(lambda (&rest args &aux start start1 values finish finish1 entryvals)
(if ,test
(unwind-protect
(progn (setq entryvals (list ,@entryforms)
start (microsec-time)
start1 *clock-cycle*
values (multiple-value-list
(apply ',(symbol-function fn) args))
finish (microsec-time) finish1 *clock-cycle*)
(values-list values))
(record-1-call ',fn (copy-list args)
(if finish values :abnormal-exit)
start start1
(or finish (microsec-time))
(or finish1 *clock-cycle*)
entryvals
(list ,@exitforms)))
(apply ',(symbol-function fn) args)))))
; perhaps we should try to correct for the time spent in the new function?
(defun forget-record-calls (fns)
(record-off fns)
(loop for fn in fns do
(setq *monitored-fns* (delete fn *monitored-fns*))
(setf (get fn 'record-calls-fn) nil)
(setf (get fn 'recorded-calls) nil)))
(defun record-on (fns)
(loop for fn in fns do
(let ((prop (get fn 'record-calls-fn)))
(cond ((not prop) (cerror "skip turning on recording"
"~A not prepared for recording" fn))
((eq (cdr prop) (symbol-function fn))
(setf (symbol-function fn) (car prop)))
((eq (car prop) (symbol-function fn)))
(t (cerror "skip turning on recording"
"~A has changed since last prepared for recording"
fn))))))
(defun record-off (fns)
(loop for fn in fns do
(let ((prop (get fn 'record-calls-fn)))
(cond ((not prop)
(cerror "continue" "~A not prepared for recording" fn))
((eq (car prop) (symbol-function fn))
(setf (symbol-function fn) (cdr prop)))
((eq (cdr prop) (symbol-function fn)))
(t (cerror "continue"
"~A has changed since recording last turned on"
fn))))))
(defun microsec-time (&aux time)
(setq time
#-(or symbolics ti) (get-internal-run-time)
#+symbolics (time:fixnum-microsecond-time)
#+TI (time:microsecond-time))
(when (< time *last-time*) (incf *clock-cycle*))
(setf *last-time* time))
(defun record-1-call (fn inputs results t1 t11 t2 t21 entryvals exitvals)
(push (list inputs results t1 t11 t2 t21 entryvals exitvals)
(get fn 'recorded-calls)))
(defun initialize-records (fns)
(loop for fn in fns do (setf (get fn 'recorded-calls) nil)))
(defun recorded-calls (fn) (get fn 'recorded-calls))
(defun summarize-calls (&optional (fns *monitored-fns*) name-alist)
(loop for fn in fns do
(summarize-record fn (get fn 'recorded-calls) name-alist)))
(defun summarize-record (fn calls name-alist)
(when calls (loop for x in calls sum 1 into ncalls
sum (elapsed (third x) (fourth x) (fifth x) (sixth x))
into time finally
(print-summarize-record fn ncalls time name-alist))))
(defun print-summarize-record (fn ncalls time name-alist)
(multiple-value-bind (total tunits)
(standardized-time-units time)
(multiple-value-bind (avg aunits)
(standardized-time-units (float (/ time ncalls)))
(format *standard-output* "~%~A: ~A calls, ~A ~A (avg. ~A~:[ ~a~; ~])"
(or (cdr (assoc fn name-alist)) fn)
ncalls total tunits avg (eq aunits tunits) aunits))))
(defun standardized-time-units (usec)
(cond ((> usec 999999) (values (float (/ usec 1000000)) "sec."))
((> usec 999) (values (float (/ usec 1000)) "msec."))
(t (values usec "usec."))))
(defun elapsed (t1 t11 t2 t21)
(+ (- t2 t1) (* (- t21 t11) (* 1024 1024 2048 #+TI 2))))
(defun longest-n-calls (fn n &key start end filterfn
&aux next time current
(candidates (recorded-calls fn)) (i 0))
; filterfn decides whether a record is "interesting"
; special cases: start/end filters out anything that starts before start
; or ends after end
(flet ((filter (e) (and (or (null start)
(plusp (elapsed start 0 (third e) (fourth e))))
(or (null end)
(plusp (elapsed (fifth e) (sixth e) end 0)))
(or (null filterfn) (funcall filterfn e)))))
(loop while (and (< i n) (setq next (pop candidates)))
when (filter next)
do (incf i) (push (cons (elapsed (third next) (fourth next)
(fifth next) (sixth next))
next) current))
(setq current (sort current #'<= :key #'car))
(loop while (setq next (pop candidates))
when (filter next)
when (< (caar current)
(setq time (elapsed (third next) (fourth next)
(fifth next) (sixth next))))
do (setq current (merge 'list (cdr current)
(list (cons time next))
#'<= :key #'car)))
(nreverse current)))
(defvar *time-line-key*
"Start time = ~A, End time = ~A, Width = ~A, ~
~& each column represents ~A ~A~
~& Key: ( = 1 entry, ) = 1 exit, * = more than one entry/exit~
~& if no entry/exit, a digit indicates number of active calls,~
~& blank indicates no change, + indicates >9 ~% ")
(defun time-line (fns &key (width 80) filterfn start end len name-alist
&aux events)
(flet ((filter (e) (and (or (null start)
(plusp (elapsed start 0 (third e) (fourth e))))
(or (null end)
(plusp (elapsed (fifth e) (sixth e) end 0)))
(or (null filterfn) (funcall filterfn e)))))
(setq events (loop for f in fns collect
(cons f (loop for e in (recorded-calls f)
when (filter e) collect e))))
(unless (and start end)
(loop for e in events do
(loop for r in (cdr e) do
(when (or (null start)
(minusp (elapsed start 0 (third r) (fourth r))))
(setq start (totalt (third r) (fourth r))))
(when (or (null end)
(minusp (elapsed (fifth r) (sixth r) end 0)))
(setq end (totalt (fifth r) (sixth r)))))))
(when (and start end) (setq len (- end start)))
(unless (and len (> len 0)) (return-from time-line "empty interval"))
(multiple-value-bind (number unit)
(when (and start end width)
(standardized-time-units (/ (- end start 0.0) width)))
(apply #'concatenate 'string
(format nil *time-line-key* start end width number unit)
(loop for f in events collect
(concatenate 'string
(let ((string (make-string width
:initial-element #\space))
index
(countstart
(make-array (list width)
:initial-element 0
:element-type 'integer))
(countend
(make-array (list width) :initial-element 0
:element-type 'integer)))
(loop for e in (cdr f) do
(setq index
(min (1- width)
(floor (* width (/ (- (totalt (third e)
(fourth e))
start)
len)))))
(incf (aref countstart index))
(setf (aref string index)
(if (char= #\space (aref string index))
#\( #\*))
(setq index
(min (1- width)
(floor (* width (/ (- (totalt (fifth e)
(sixth e))
start)
len)))))
(decf (aref countend index))
(setf (aref string index)
(if (char= #\space (aref string index))
#\) #\*)))
(loop for i below width with sum = 0 do
(setf sum (+ sum (aref countstart i)
(aref countend i)))
(when (and (/= i 0)
(/= (aref countstart (1- i)) 0)
(/= (aref countend (1- i)) 0)
(char= #\space (aref string i))
(> sum 0))
(setf (aref string i)
(if (> sum 9) #\+ (aref "0123456789" sum)))))
string)
(format nil " ~A~& "
(symbol-name (or (cdr (assoc (car f) name-alist))
(car f))))))))))
(defun outermost (calls &aux outer)
(loop for c in calls
unless (and outer (<= (totalt (third outer) (fourth outer))
(totalt (third c) (fourth c))
(totalt (fifth c) (sixth c))
(totalt (fifth outer) (sixth outer))))
collect (setf outer c)))
; get the time represented by the two numbers x (low order) and y (high order)
(defun totalt (x y) (elapsed 0 0 x y))

129
contrib/pvm/eclreader.lsp
View file

@ -1,129 +0,0 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = eclreader.lsp
;;; Definition of reader for ECoLISP.
;;;
;;; (c) 1994, I.D. Alexander-Craig, all rights reserved.
;;;
;;;
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Definition of the basic reader that is needed by KCL. ;;;;
;;;; The following function should be called when loading the ;;;;
;;;; object reader for KCL. This is called the default reader ;;;;
;;;; for KCL. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defparameter *default-reader* ())
(defparameter *default-reader-specs*
(list
(list 'NULL
LISP_NIL_TYPE
*
#'(lambda (rdr)
(declare (ignore rdr))
()))
(list T
LISP_T_TYPE
'*
#'(lambda (rdr)
(declare (ignore rdr))
t))
(list 'STANDARD-CHAR ;; CHARACTER
LISP_CHAR_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-char obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-char)))
(list 'FIXNUM
LISP_INT_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-int obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-int)))
(list 'BIGNUM
LISP_LONGINT_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-longint obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-longint)))
(list 'LONG-FLOAT ;;FLOAT
LISP_DOUBLE_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-double obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-double)))
(list 'SYMBOL
LISP_SYMBOL_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(cond ((eq obj t)
(C-obuffer-t))
((null obj)
(C-obuffer-nil))
(t
(let ((pname (symbol-name obj)))
(C-obuffer-symbol pname (length pname))))))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-symbol)))
(list 'STRING ;; SIMPLE-STRING
LISP_STRING_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-string obj (length obj)))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-string)))
(list 'VECTOR
LISP_VECTOR_TYPE
#'(lambda (obj rdr)
(encode-vector obj rdr))
#'(lambda (rdr)
(decode-vector rdr)))
(list 'CONS
LISP_LIST_TYPE
#'(lambda (obj rdr)
(encode-list obj rdr))
#'(lambda (rdr)
(decode-list rdr)))))
;; For testing only:
(defparameter *rdr* ())
(defun init-default-reader ()
(setq *default-reader* (make-object-reader))
(initialise-reader-object
*default-reader*
*default-reader-specs*)
(values))
(format t "Creating reader:~%")
(init-default-reader)
(format t "Done.~%~%")
;;; For testing only:
(setq *rdr* *default-reader*)
(defun restart-reader ()
(setq *default-reader* ()
rdr ())
(init-default-reader)
(setq *rdr* *default-reader*)
(values))

2
contrib/pvm/hostfile
View file

@ -1,2 +0,0 @@
database
igor

11
contrib/pvm/load.lsp
View file

@ -1,11 +0,0 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = load.lsp
;;; Load file for ECL<->PVM interface modules.
;;;
(load "pvmconsts")
(load "pvmlisp")
(si:faslink "pvmecl" "-L/project/pvm/pvm3/lib/SUN4 -lgpvm3 -lpvm3 -lc")
;(load "pvmecl")
(load "eclreader")

14
contrib/pvm/pvm-test.lsp
View file

@ -1,14 +0,0 @@
(defparameter *my-tid* ())
(defun enroll ()
(setq *my-tid* (lpvm-my-tid)))
(defun leave ()
(lpvm-exit)
(quit))
(defun send-rec (msg msgtype)
(format t "about to send~%")
(lpvm-send-message msg *rdr* msgtype *my-tid*)
(format t "about to receive~%")
(lpvm-nonblocking-recv *rdr* *my-tid* msgtype))

109
contrib/pvm/pvmconsts.lsp
View file

@ -1,109 +0,0 @@
;;;-*- Mode: LISP; Syntax: Common LISP; Base: 10 -*-
;;;
;;; File = pvmconsts.lisp
;;;
;;; PVM constant definitions.
;;;
;;
;; Change log.
;; 25 March 1994. LISP_X_TYPE constants have contiguous values.
;; This is to support the new representation for the read structure.
;;
;;;
;;; Constant definitions for type tags used to define
;;; message boundaries.
;;; The tags are all ad hoc and tailored to the needs of LISP.
;;; Each is represented by an integer.
;;;
;;;
(defconstant MESSAGE_START 1)
;; This says that there is going to be
;; a new structure type that follows.
(defconstant LISP_NIL_TYPE 2) ; encode nil
(defconstant LISP_T_TYPE 3) ; encode t
(defconstant LISP_CHAR_TYPE 4)
(defconstant LISP_SHORTINT_TYPE 5)
(defconstant LISP_INT_TYPE 6)
(defconstant LISP_LONGINT_TYPE 7)
;(defconstant LISP_FLOAT_TYPE 8) not used in ECo or KCL
(defconstant LISP_DOUBLE_TYPE 9)
(defconstant LISP_SYMBOL_TYPE 10)
(defconstant LISP_STRING_TYPE 11)
(defconstant LISP_VECTOR_TYPE 12)
(defconstant LISP_LIST_TYPE 13)
;; If complex and rational are required, we can fit them in.
(defconstant LISP_OPAQUE_TYPE 14)
(defconstant LISP_MIN_USER_TYPE 15)
;;;
;;; PVM constant definitions for error messages, together
;;; with the error function for PVM routines.
;;;
(defconstant %PvmOk 0)
(defconstant %PvmBadParam -2)
(defconstant %PvmMismatch -3)
(defconstant %PvmNoData -5)
(defconstant %PvmNoHost -6)
(defconstant %PvmNoFile -7)
(defconstant %PvmNoMem -10)
(defconstant %PvmBadMsg -12)
(defconstant %PvmSysErr -14)
(defconstant %PvmNoBuf -15)
(defconstant %PvmNoSuchBuf -16)
(defconstant %PvmNullGroup -17)
(defconstant %PvmDupGroup -18)
(defconstant %PvmNoGroup -19)
(defconstant %PvmNotInGroup -20)
(defconstant %PvmNoInst -21)
(defconstant %PvmHostFail -22)
(defconstant %PvmNoParent -23)
(defconstant %PvmNotImpl -24)
(defconstant %PvmDSysErr -25)
(defconstant %PvmBadVersion -26)
(defconstant %PvmOutOfRes -27)
(defconstant %PvmDupHost -28)
(defconstant %PvmCantStart -29)
(defconstant %PvmAlready -30)
(defconstant %PvmNoTask -31)
(defconstant %PvmNoEntry -32)
(defconstant %PvmDupEntry -33)
(defun pvm-error (errno where)
;; quick hack for testing
(unless (= errno %PvmOk)
(error "PVM error in ~s no. ~d~%" where errno)))
;;;
;;; Constants for pvm_advise
;;;
(defconstant %PvmDontRoute 1)
(defconstant %PvmAllowDirect 2)
(defconstant %PvmRouteDirect 3)
;;;
;;; Constants for pvm_initsend's encoding
;;;
(defconstant %PvmDataDefault 0) ; use XDR if heterogeneous
(defconstant %PvmDataRaw 1) ; no encoding
(defconstant %PvmDataInPlace 2) ; leave data in place.
;;;
;;; Constants for pvm_spawn.
;;; See the PVM manual p. 13 for details.
;;;
(defconstant %PvmTaskDefault 0)
(defconstant %PvmTaskHost 1)
(defconstant %PvmTaskArch 2)
(defconstant %PvmTaskDebug 4)
(defconstant %PvmTaskTrace 8)

1058
contrib/pvm/pvmecl.c
View file

File diff suppressed because it is too large Load diff

756
contrib/pvm/pvmecl.lsp
View file

@ -1,756 +0,0 @@
;;;-*-Mode:LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = pvmecl.lsp
;;; Interface between ECoLISP and PVM.
;;; This file contains the C function interface between ECoLisp and PVM.
;;; It is not portable.
;;;
;;;
;;; (c) 1994, I.D. Alexander-Craig, all rights reserved.
;;;
;;;
;;;
;;; pvmconsts.lsp must be loaded before this file.
;;;
;;;
;;; Error function for PVM interface.
;;;
(defun pvm-error (errno routine)
(error "PVM interface error ~d in ~a~%" errno routine))
(clines "
#include \"/project/pvm/pvm3/include/pvm3.h\"
")
;;;
;;; Begin with buffering routines.
;;;
;;
;; Start with output buffering routines for simple types.
;; Each C function is followed by the corresponding entry
;; definition. Then comes the LISP function.
;;
(definline c_pvm_pkint (fixnum) fixnum
"({int x = #0; pvm_pkint(&x,1,1);})"
)
(defun obuffer-int (i)
(let ((info (c_pvm_pkint i)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-int")))
(values))
;;
;; Packing routine for message types. This is a LISP function
;; that calls c_pvm_pkint to pack the type.
;;
(defun pack-type-tag (typetag)
(let ((return-code (c_pvm_pkint typetag)))
(unless (= %PvmOk return-code)
(pvm-error return-code "pack-type-tag")))
(values))
(defun C-obuffer-nil ()
(pack-type-tag LISP_NIL_TYPE))
(defun C-obuffer-t ()
(pack-type-tag LISP_T_TYPE))
(definline c_pvm_pkchar (character) fixnum
"({char x = #0; pvm_pkbyte(&x,1,1);})"
)
(defun C-obuffer-char (ch)
(pack-type-tag LISP_CHAR_TYPE)
(let ((info (c_pvm_pkchar ch)))
(unless (= %PvmOk info)
(pvm-error info "pvm_pkchar call")))
(values))
(defun C-obuffer-int (i)
(pack-type-tag LISP_INT_TYPE)
(let ((info (c_pvm_pkint i)))
(unless (= %PvmOk info)
(pvm-error info "pvm_pkint call")))
(values))
(definline c_pvm_pkfloat (short-float) fixnum
"({float x = #0; pvm_pkfloat(&x,1,1);})"
)
(defun obuffer-float (fl)
(let ((info (c_pvm_pkfloat fl)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-float")))
(values))
(definline c_pvm_pkdouble (long-float) fixnum
"({double x = #0; pvm_pkdouble(&x,1,1);})"
)
(defun C-obuffer-double (db)
(let ((info (c_pvm_pkdouble db)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-double")))
(values))
;;
;; Packing routines for symbol and string.
;; Both routines expect a string and a number (in that order)
;; to be supplied to them.
;; The number is the length of the string.
;;
;;
;; The first function packs the length and the string into
;; the output buffer.
;;
(definline c_pvm_pkstr (string fixnum) fixnum
"({int type = #1;
type = pvm_pkint(&type,1,1);
((type == PvmOk) ? pvm_pkstr((#0)->st.st_self) : type);})"
)
;;
;; Now define the routines that manipulate symbols and strings.
;;
(defun C-obuffer-symbol (s)
(let ((pname (symbol-name s)))
(let ((len (length pname)))
(pack-type-tag LISP_SYMBOL_TYPE)
(let ((info (c_pvm_pkstr pname len)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-symbol")))))
(values))
(defun C-obuffer-string (str)
(let ((len (length str)))
(pack-type-tag LISP_STRING_TYPE)
(let ((info (c_pvm_pkstr str len)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-string"))))
(values))
;;
;; Packing routines for vector and list headers.
;;
(defun C-obuffer-vector-header (vector-length)
(pack-type-tag LISP_VECTOR_TYPE)
(let ((info (c_pvm_pkint vector-length)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-vector-header")))
(values))
(defun C-obuffer-list-header ()
(pack-type-tag LISP_LIST_TYPE)
(values))
;;
;; Unpacking routines for scalar types.
;;
(defcbody c_pvm_unpack_tag () object
" Cnil;
{ int tagval, info;
info = pvm_upkint(&tagval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = MAKE_FIXNUM(tagval);
RETURN(2);
}"
)
;(proclaim '(inline ibuffer-tag))
(defun ibuffer-tag ()
(multiple-value-bind (info value)
(c_pvm_unpack_int)
(if info
value
(pvm-error info "ibuffer-tag"))))
(defun C-next-msg-type ()
(ibuffer-tag))
(defun C-next-type-name ()
(ibuffer-tag))
(defcbody c_pvm_unpack_int () object
" Cnil;
{ int ival, info;
info = pvm_upkint(&ival,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = MAKE_FIXNUM(ival);
RETURN(2);
}"
)
(defun C-ibuffer-int ()
(multiple-value-bind (info value)
(c_pvm_unpack_int)
(if info
value
(pvm-error info "ibuffer-int"))))
(defcbody c_pvm_unpack_char () object
" Cnil;
{ int info;
char chval;
info = pvm_upkbyte(&chval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = code_char(chval);
RETURN(2);
}"
)
(defun C-ibuffer-char ()
(multiple-value-bind (info value)
(c_pvm_unpack_char)
(if info
value
(pvm-error info "ibuffer-char"))))
(defcbody c_pvm_unpack_float () object
" Cnil;
{ int info;
float fval;
info = pvm_upkfloat(&fval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_shortfloat(fval);
RETURN(2);
}"
)
(defun ibuffer-float ()
(multiple-value-bind (info value)
(c_pvm_unpack_float)
(if info
value
(pvm-error info "ibuffer-float"))))
(defcbody c_pvm_unpack_double () object
" Cnil;
{
int info;
double dval;
info = pvm_upkdouble(&dval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_longfloat(dval);
RETURN(2);
}"
)
(defun C-ibuffer-double ()
(multiple-value-bind (info value)
(c_pvm_unpack_double)
(if info
value
(pvm-error info "ibuffer-double"))))
;;
;; Routines to get symbols and strings from the PVM
;; buffer.
;; This is a little tricky!
;;
;;
;; First, a general unpacking routine for strings.
;;
(defun setstring (chr indx str)
(setf (aref str indx) chr)
(values))
(defcbody c_pvm_unpack_chars (fixnum) object
"
Cnil;
{ char *strchrs;
int info;
info = pvm_upkstr(strchrs);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_simple_string(strchrs);
RETURN(2);
}"
)
;;
;; Now the routine which gets the length and the string
;; from the buffer.
;;
(defun get-length-and-string ()
(let ((len (ibuffer-int)))
(multiple-value-bind (info str)
(c_pvm_unpack_chars len)
(if info
(if (= (length str) len)
str
(format
t
"received string has length ~a, not ~a as promised.~%"
(length str)
len))
(pvm-error info "get-length-and-string")))))
(defun C-ibuffer-symbol ()
; It might be useful sometimes just to return the string.
(let ((pname (get-length-and-string)))
(make-symbol pname)))
(defun C-ibuffer-string ()
(get-length-and-string))
(defun C-ibufer-vector-length ()
(C-ibuffer-int))
;;;
;;; Send and received routines (together with registration and exit).
;;;
(definline c_pvm_initsend (fixnum) fixnum
"pvm_initsend(#0)")
(defun lpvm-init-send (encoding)
(cond ((not (integerp encoding))
(error "lpvm-init-send expects an int, not a ~a~%"
(type-of encoding)))
((minusp encoding)
(error
"lpvm-init-send: encoding must be non-negative (~d)~%"
encoding))
(t
(let ((bufid (c_pvm_initsend encoding)))
(when (minusp bufid)
(pvm-error bufid "pvm_initsend call"))
bufid))))
(definline c_pvm_send (fixnum fixnum) fixnum
"pvm_send(#0, #1)")
;;;
;;; The send routine.
;;;
(defun lpvm-send-message (lisp-object
reader-object
message-type
destination-task
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(let ((info (c_pvm_send destination-task message-type)))
(when (minusp info)
(pvm-error info "pvm_send call")))
(values))
;;;
;;; The multi-cast routine is similar, but we set up the buffer
;;; once and then repeatedly send the message.
;;;
(defun lpvm-multicast (lisp-object
reader-object
message-type
destination-tasks
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(dolist (tid destination-tasks)
(let ((info (c_pvm_send tid message-type)))
(when (minusp info)
(pvm-error info "pvm_multicast"))))
(values))
;;;
;;; Receive routines.
;;;
(definline c_pvm_nrecv (fixnum fixnum) fixnum
"pvm_nrecv(#0,#1)"
)
(defun lpvm-nonblocking-recv (object-reader tid msgtag)
(let ((bufid (c_pvm_nrecv tid msgtag)))
(cond ((minusp bufid)
(pvm-error bufid "pvm_nrecv"))
((= %PvmOk bufid)
()) ; nothing there
((plusp bufid)
(read-object object-reader))
(t
(error
"something weird has happened---nonblocking-recv")))))
(definline c_pvm_recv (fixnum fixnum) fixnum
"pvm_recv(#0, #1)"
)
(defun lpvm-blocking-read (object-reader tid msgtag)
(let ((bufid (c_pvm_recv tid msgtag)))
(when (minusp bufid)
(pvm-error bufid "pvm_recv"))
(read-object object-reader)))
;;;
;;; Join PVM primitive.
;;;
(definline c_pvm_mytid () fixnum
"pvm_mytid()"
)
(defun lpvm-my-tid ()
(let ((info (c_pvm_mytid)))
(when (minusp info)
(pvm-error info "pvm_mytid call"))
info))
;;;
;;; Leave PVM primitive.
;;;
(definline c_pvm_exit () fixnum
"pvm_exit()")
(defun lpvm-exit ()
(let ((info (c_pvm_exit)))
(unless (= %PvmOk info)
(pvm-error info "pvm_exit call")))
(values))
(definline c_pvm_kill (fixnum) fixnum
"pvm_kill(#0)"
)
(defun lpvm-kill (tid)
(let ((info (c_pvm_kill tid)))
(when (minusp info)
(pvm-error info "pvm_kill call")))
(values))
(definline c_pvm_parent () fixnum
"pvm_parent()"
)
(defun lpvm-parent ()
(let ((info (c_pvm_parent)))
(when (= info %PvmNoParent)
(pvm-error info "pvm_parent")))
(values))
(definline c_pvm_pstat (fixnum) fixnum
"pvm_pstat(#0)"
)
(defun lpvm-pstat (tid)
(let ((info (c_pvm_pstat tid)))
(cond ((= info %PvmOk)
info)
((= info %PvmNoTask)
info)
(t
(pvm-error info "pvm_stat call")))))
(definline c_pvm_mstat (string) fixnum
"pvm_mstat(#0->st.st_self)"
)
(defun lpvm-mstat (hostname)
(unless (stringp hostname)
(error "lpvm-mstat: hostnames must be strings, not ~a~%"
(type-of hostname)))
(let ((info (c_pvm_mstat hostname)))
(cond ((= info %PvmOk)
'running)
((= info %PvmNoHost)
'no-such-host)
((= info %PvmHostFail)
'host-unreachable)
(t
(pvm-error info "pvm_mstat call")))))
(defcbody c_pvm_spawn (string fixnum string fixnum) object
"
Cnil;
{
int numt, tid, i;
int sz = #1;
object v;
extern object lisp_package;
siLmake_vector(7, intern(\"FIXNUM\", lisp_package),
MAKE_FIXNUM(sz), Cnil, Cnil, Cnil, Cnil, Cnil);
v = VALUES(0);
numt = pvm_spawn(#0->st.st_self, 0, #1, #2->st.st_self, #3, v->v.v_self);
if (numt < PvmOk) RETURN(1);
VALUES(0) = MAKE_FIXNUM(numt);
VALUES(1) = v;
RETURN(2);
}"
)
(defun lpvm-spawn (taskname flag where numtasks)
(cond ((not (stringp taskname))
(error "spawn -- wrong type: ~A" (type-of taskname)))
((not (integerp flag))
(error "spawn -- wrong type: ~A" (type-of flag)))
((not (stringp where))
(error "spawn -- wrong type: ~A" (type-of where)))
((not (integerp numtasks))
(error "spawn -- wrong type: ~A" (type-of numtasks)))
((not (and (<= 1 numtasks)
(<= numtasks 32)))
(error "spawn -- wrong number of tasks: ~D" numtasks))
(t
(multiple-value-bind (num-spawned tids)
(c_pvm_spawn taskname flag where numtasks)
(if (minusp num-spawned)
(pvm-error num-spawned "pvm_spawn call")
(values num-spawned tids))))))
(definline c_pvm_sendsig (fixnum fixnum) fixnum
"pvm_sendsig(#0,#1)"
)
(defun lpvm-sendsig (tid signum)
(let ((info (c_pvm_sendsig tid signum)))
(when (minusp info)
(pvm-error info "pvm_sendsig call")))
(values))
(definline c_pvm_advise (fixnum) fixnum
"pvm_advise(#0)"
)
(defun lpvm-advise (route)
(let ((info (c_pvm_advise route)))
(unless (= info %PvmOk)
(pvm-error info "pvm_advise call")))
(values))
;;;;
;;;; Group operations.
;;;;
(definline c_pvm_join_group (object) fixnum
"pvm_joingroup(#0->st.st_self)"
)
(defun lpvm-join-group (group)
(unless (stringp group)
(error "lpvm-join-grou expects a string, not a ~a~%"
(type-of group)))
(let ((inum (c_pvm_joingroup group)))
(when (minusp inum)
(pvm-error inum "pvm_joingroup call"))
inum))
(definline c_pvm_leave_group (object) fixnum
"pvm_lvgroup(#0->st.st_self)"
)
(defun lpvm-leave-group (group)
(unless (stringp group)
(error
"lpvm-leave-group expects a string, not a ~a~%"
(type-of group)))
(let ((info (c_pvm_leave_group group)))
(when (minusp info)
(pvm-error info "pvm_lvgroup call")))
(values))
(definline c_pvm_get_tid (object fixnum) fixnum
"pvm_gettid(#0->st.st_self, #1)"
)
(defun lpvm-get-tid (group inum)
(unless (stringp group)
(error
"lpvm-get-tid expects arg 1 to be a string, not a ~a~%"
(type-of group)))
(unless (integerp inum)
(error
"lpvm-get-tid expects arg 2 to be an int, not a ~a~%"
(type-of inum)))
(let ((info (c_pvm_get_tid group inum)))
(cond ((plusp info)
info)
((minusp info)
(pvm-error info "pvm_gettid call"))
(t
(pvm-error 0 "pvm_gettid: should not happen")))))
(definline c_pvm_get_inst (object fixnum) fixnum
"pvm_getinst(#0->st.st_self, #1)"
)
(defun lpvm-get-inst-no (group tid)
(cond ((not (stringp group))
(error
"lpvm-get-inst-no expects arg1 to be a string, not a ~a~%"
(type-of group)))
((not (integerp tid))
(error
"lpvm-get-inst-no expects arg2 to be an int, not a ~a~%"
(type-of tid)))
(t
(let ((inum (c_pvm_get_inst group tid)))
(when (minusp inum)
(pvm-error inum "pvm_getinst call"))
inum))))
(definline c_pvm_grpsize (object) fixnum
"pvm_gsize(#0->st.st_self)"
)
(defun lpvm-group-size (group)
(unless (stringp group)
(error
"lpvm-group-size expects a string not a ~a~%"
(type-of group)))
(let ((size (c_pvm_grpsize group)))
(when (minusp size)
(pvm-error size "pvm_gsize call"))
size))
(definline c_pvm_barrier (object fixnum) fixnum
"pvm_barrier(#0->st.st_self,#1)"
)
(defun lpvm-barrier (group count)
(cond ((not (stringp group))
(error
"lpvm-barrier expects arg 1 to be a string, not a ~a~%"
(type-of group)))
((not (integerp count))
(error
"lpvm-barriet expects arg 2 to be an int, not a ~a~%"
(type-of count)))
(t
(let ((info (c_pvm_barrier group count)))
(unless (= %PvmOk info)
(pvm-error info "pvm_barrier call")))))
(values))
(definline c_pvm_broadcast (object fixnum) fixnum
"pvm_bcast(#0->st.st_self,#1)"
)
(defun lpvm-broadcast (lisp-object
reader-object
message-type
group-name
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(let ((info (c_pvm_broadcast group-name message-type)))
(when (minusp info)
(pvm-error info "pvm_bcast call")))
(values))
(defCbody c_pvm_probe (fixnum fixnum) fixnum
"0;
{ int bufid, info;
int *bytes;
int out_tid, out_tag;
VALUES(0) = Cnil;
bufid = pvm_probe(#0,#1);
if (bufid == 0) RETURN(1);
if (bufid < 0) {
VALUES(0) = CONS(MAKE_FIXNUM(bufid), Cnil);
RETURN(1);
}
info = pvm_bufinfo(bufid,bytes,&out_tag,&out_tid);
VALUES(0) = list(3, MAKE_FIXNUM(info), MAKE_FIXNUM(out_tag),
MAKE_FIXNUM(out_tid));
RETURN(1);
}"
)
(defun lpvm-probe (tid msgno)
(let ((return-val (c_pvm_probe tid msgno)))
(let ((num-returned (length return-val))
(out-tid 0)
(out-tag 0)
(info 0))
(cond ((= num-returned 1)
(pvm-error (car return-val) "pvm_probe call"))
(t
(setf info (first return-val))
(setf out-tag (second return-val))
(setf out-tid (third return-val))
(if (= info %PvmOk)
(values out-tid out-tag)
(pvm-error info "pvm_probe call")))))))
;;;;
;;;; Add and delete hosts.
;;;;
;;
;; add_host adds a single host to the machine. hostname is the
;; string name of the host. The function returns a pair.
(defCbody c_pvm_add_host (object) object
"Cnil;
{ int host_info[1];
int info, hival;
info = pvm_addhosts(&(#0)->st.st_self,1,host_info);
hival = host_info[0];
VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival));
RETURN(1);
}"
)
(defun add-hosts (hostnames)
(let ((results (make-array (length hostnames))))
(dotimes (host (length hostnames))
(let ((host (aref hostnames)))
(c_pvm_add_host host)
(setf (aref results host)(cadr host))))
results))
(defCbody c_pvm_del_host (object) object
"Cnil;
{ int host_info[1];
int info, hival;
info = pvm_delhosts(&(#0)->st.st_self,1,host_info);
hival = host_info[0];
VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival));
RETURN(1);
}"
)
(defun del-hosts (hostnames)
(let ((results (make-array (length hostnames))))
(dotimes (host (length hostnames))
(let ((host (aref hostnames)))
(c_pvm_add_host host)
(setf (aref results host) (cadr host))))
results))

620
contrib/pvm/pvmlisp.lsp
View file

@ -1,620 +0,0 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = pvmlisp.lsp
;;;
;;; New version of reader structure using vectors.
;;;
;;;
;;; This code only works with Common LISP. It should not be included
;;; in a CLOS program (yet). It will also not work with CLiCC.
;;;
;;;
;;; Message-start-p is used to detect the start of a complex message.
;;; It is true if it is applied to a message tag.
;;;
(defun message-start-p (mty)
(and (integerp mty)
(= MESSAGE_START mty)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; We define the reader object. This is a structure containing ;;;;
;;;; the function closures which perform the encoding and decoding. ;;;;
;;;; We begin by defining the encoder and decoder structures and ;;;;
;;;; manipulation functions (this will be a dream in CLOS or ;;;;
;;;; TELOS!) ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; The encoder structure.
;;; The design of the encoder is such that it allows users to configure
;;; their own encoders. For example, CMU CL calls a SIMPLE-STRING a
;;; SIMPLE-BASE-STRING. This can be accomodated within this organisation
;;; at the cost of a little effort.
;;;
(defstruct encoder-rec
typename ;; value returned by type-of and used to index the
;; encoder function
msgtypeno ;; the numeric message type
encoder-fn)
;;;
;;; Encoders are held in hash tables. The following function (which
;;; should be inline) creates such a table.
;;;
;(declaim (inline make-encoder-structure))
(proclaim '(inline make-encoder-structure))
(defun make-encoder-structure ()
(make-hash-table :test #'eq))
;;;
;;; encoder-present-p is true if there is an encoder for the
;;; named type in the encoder table.
;;;
(defun encoder-present-p (enc-struc typename)
(multiple-value-bind (encrec there)
(gethash typename enc-struc)
(declare (ignore encrec))
there))
;;;
;;; Retrieval function for encoders. Given a type name, it returns the
;;; encoder function associated with the type.
;;;
(defun get-encoder (enc-struc typename)
(multiple-value-bind (encoder-rec known-type)
(gethash typename enc-struc)
(if known-type
(encoder-rec-encoder-fn encoder-rec)
())))
;;;
;;; Routine to store an encoder function.
;;; Assumes that typename and typeno have been checked.
;;;
(defun put-encoder (enc-struc typename typeno encoder-fn)
(setf (gethash typename enc-struc)
(make-encoder-rec :encoder-fn encoder-fn
:typename typename
:msgtypeno typeno))
(values))
;;;****************************************************************;;;
;;; ;;;
;;; ;;;
;;; A routine to replace the encoder function and a routine to ;;;
;;; remove an encode could be added here. ;;;
;;; ;;;
;;; ;;;
;;;****************************************************************;;;
;;;
;;; message-type-number returns the type number associated with a
;;; symbolic type name. Its input is an encoder structure.
;;;
(defun message-type-number (enc-struc typename)
(multiple-value-bind (enc-rec known-type)
(gethash typename enc-struc)
(if known-type
(encoder-rec-msgtypeno enc-rec)
(error "cannot return type number for type ~a: unknown type.~%"
typename))))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; The decoder structure and containing object. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; The decoder is indexed by its message type number.
;;; Decoders have a symbolic identifier associated with them.
;;;
(defstruct decoder-rec
typename
decoder-fn)
;;;
;;; Decoders are held in a hash table. The table is indexed by the
;;; message number. The hash table representation is used so that
;;; users can have gaps in their message number sequences.
;;;
;(declaim (inline make-decoder-structure))
(proclaim '(inline make-decoder-structure))
(defun make-decoder-structure ()
(make-hash-table :test #'eql))
;;;
;;; decoder-present-p is true if there is a decoder structure
;;; in the decoder table at the point indexed by the numeric
;;; message type.
;;;
(defun decoder-present-p (dec-struc msg-type-no)
(multiple-value-bind (decrec there)
(gethash msg-type-no dec-struc)
(declare (ignore decrec))
there))
;;;
;;; get-decoder returns the decoder function associated with a
;;; message type number. If there is no such message, an error is raised.
;;;
(defun get-decoder (decoder-struc msg-no)
(multiple-value-bind (decrec there)
(gethash msg-no decoder-struc)
(if there
(decoder-rec-decoder-fn decrec)
())))
;;;
;;; put-decoder inserts a decoder record into the decoder vector.
;;; If a decoder structure is already in the vector at the place
;;; indexed by the message number, an error is raised.
;;;
;;; Note that this function will expand the vector if there is
;;; insufficient room.
;;;
(defun put-decoder (decoder-struc msg-no msg-typename decoder-fn)
(setf (gethash msg-no decoder-struc)
(make-decoder-rec :typename msg-typename
:decoder-fn decoder-fn))
(values))
;;;****************************************************************;;;
;;; ;;;
;;; ;;;
;;; A routine to replace the decoder function and a routine to ;;;
;;; remove an encode could be added here. ;;;
;;; ;;;
;;; ;;;
;;;****************************************************************;;;
;;;
;;; message-number-type returns the symbolic name associated with
;;; a numeric message type.
;;;
(defun message-number-type (decoder-struc msg-type-no)
(decoder-rec-typename
(aref decoder-struc msg-type-no)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; The reader object and its associated functions. ;;;;
;;;; Note that encoder and decoders can be added or removed at ;;;;
;;;; runtime. ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defstruct reader-object
(encoders (make-encoder-structure))
(decoders (make-decoder-structure))
(known-type-names ()))
;;;
;;; A creation function for readers.
;;;
(defun make-object-reader ()
(make-reader-object))
;;;
;;; add-type-name adds a symbolic type name to the reader object.
;;;
;(declaim (inline add-type-name))
(proclaim '(inline add-type-name))
(defun add-type-name (reader-obj typename)
(pushnew typename
(reader-object-known-type-names reader-obj)
:test #'eq)
(values))
;;;; A deletion function can easily be defined.
;;;
;;; valid-type-name-p is true iff the type name supplied as
;;; the second argument is known to the reader supplied as the
;;; first argument.
;;;
;(declaim (inline valid-type-name-p))
(proclaim '(inline valid-type-name-p))
(defun valid-type-namex-p (reader-obj typename)
(member typename
(reader-object-known-type-names reader-obj)
:test #'eq))
;(declaim (inline known-type-name-p))
(proclaim '(inline known-type-name-p))
(defun known-type-name-p (reader-obj typename)
(member typename
(reader-object-known-type-names reader-obj)
:test #'eq))
;;;
;;; valid-message-type-no-p is true if the message type number
;;; supplied as the second argument is (i) positive and (ii) in the
;;; range 0 .. (length decoders)
;;;
;(declaim (inline valid-message-type-no-p))
(proclaim '(inline valid-message-type-no-p))
(defun valid-message-type-no-p (reader-obj msg-typeno)
(multiple-value-bind (decrec present)
(gethash msg-typeno
(reader-object-decoders reader-obj))
(declare (ignore decrec))
present))
;(declaim (inline known-type-number-p))
(proclaim '(inline known-type-number-p))
(defun known-type-number-p (reader-obj msg-typeno)
(multiple-value-bind (decrec present)
(gethash msg-typeno
(reader-object-decoders reader-obj))
(declare (ignore decrec))
present))
;;;
;;; Routines to add encoder and decoder functions to a reader object.
;;; They can be called at runtime as well as at configuration time.
;;; Procedures to replace readers and writers could be defined if
;;; necessary---they won't be too difficult.
;;;
(defun add-encoder (reader-obj ;; the reader object
message-type-no ;; the numeric type of the
;; message type
message-type-name ;; the symbolic name of the
;; message type
encoder-function) ;; the encoder function proper
; start by checking that the type is not already known.
(when (and (known-type-name-p reader-obj message-type-name)
(encoder-present-p (reader-object-encoders reader-obj)
message-type-name))
(error
"add-encoder: cannot add encoder for ~a -- one already present~%"
message-type-name))
; try to add the type name (a decoder might have put it there already)
(add-type-name reader-obj message-type-name)
; add the encoder function
(put-encoder (reader-object-encoders reader-obj)
message-type-name
message-type-no
encoder-function)
(values))
(defun add-decoder (reader-obj ;; the reader object
message-type-no ;; the numeric type of the
;; message type
message-type-name ;; the symbolic name of the
;; message type
decoder-function) ;; the encoder function proper
; start by checking that the type is not already known
(when (and (known-type-name-p reader-obj message-type-name)
(decoder-present-p (reader-object-decoders reader-obj)
message-type-no))
(error
"add-decoder: cannot add decoder for ~a -- one already present~%"
message-type-name))
; try to add the type name (an encoder might have already added it)
(add-type-name reader-obj message-type-name)
; add the decoder function
(put-decoder (reader-object-decoders reader-obj)
message-type-no
message-type-name
decoder-function)
(values))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Some utility functions. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; Only proper lists can be transmitted and received -- sorry.
;;;
(defun proper-listp (l)
(and (not (null l))
(list l)
(null (cdr (last l)))))
;;;
;;; type-name is used in indexing the encoders.
;;;
(defun type-name (typ)
(if (symbolp typ)
typ
(car typ)))
;;;
;;; initialise-reader-object takes a reader object as its first
;;; argument and a list of lists of the following form:
;;; (typename -- a symbol
;;; typeno -- a natural number (one of the LISP_X_TYPEs)
;;; encoder -- a closure or the symbol '*
;;; decoder -- a closure or the symbol '*
;;; )
;;;
(defun initialise-reader-object (reader-obj ;; the reader to be started.
specs) ;; a list of reader and writer
;; specifications
(dolist (spec specs)
(let ((typename (first spec))
(typeno (second spec))
(encfn (third spec))
(decfn (fourth spec)))
(when (and (symbolp encfn)
(eq encfn '*)
(symbolp decfn)
(eq decfn '*))
(error
"initialise reader: reader and writer for ~a both unspecified.~%"
typename))
(unless (and (symbolp encfn)
(eq '* encfn))
; add an encoder.
(add-encoder reader-obj typeno typename encfn))
(unless (and (symbolp decfn)
(eq '* decfn))
(add-decoder reader-obj typeno typename decfn))))
(values))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Routines to apply encoders and decoders. These are the core ;;;;
;;;; of the module. ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defun apply-encoder (objectreader ;; reader in which to look for encoder
lisp-object) ;; object to encode
(let ((tname (type-name (type-of lisp-object))))
(cond ((not (known-type-name-p objectreader tname))
(error
"apply-encoder: cannot encode -- unknown type ~a for object ~a~%"
tname
lisp-object))
(t
(let ((encode-fn (get-encoder
(reader-object-encoders objectreader)
tname)))
(cond ((null encode-fn)
(error
"apply-encoder: no writer function for type ~a~%"
tname))
(t
(funcall encode-fn lisp-object objectreader)))))))
(values))
(defun apply-decoder (objectreader ;; the reader in which to look
message-type-no) ;; the number of the message
(cond ((not (known-type-number-p objectreader message-type-no))
(error
"apply-decoder: cannot decode -- unknown message type number ~d~%"
message-type-no))
(t
(let ((decoder-struc (reader-object-decoders objectreader)))
(let ((decoder-fn (get-decoder decoder-struc message-type-no)))
(if (null decoder-fn)
(error
"apply-decoder: no reader function for type ~a~%"
(message-number-type decoder-struc message-type-no))
(funcall decoder-fn objectreader)))))))
;;;****************************************************************;;;
;;; ;;;
;;; User interface functions. ;;;
;;; ;;;
;;;****************************************************************;;;
(defun write-object (object reader)
(apply-encoder reader object))
(defun write-user-object-type (object reader)
(let ((encoders (reader-object-encoders reader)))
(multiple-value-bind (encrec there)
(gethash (type-name (type-of object))
encoders)
(if there
(let ((msgno (encoder-rec-msgtypeno encrec)))
(when (>= msgno LISP_MIN_USER_TYPE)
(C-set-message-type msgno)))
(error
"write-object: no encoder information for type ~a~%"
(type-name (type-of object)))))))
(defun read-object (reader)
(let ((next-object-type (C-next-msg-type)))
(format t "got next type: ~A~%" (type-of next-object-type))
(when (message-start-p next-object-type)
(setf next-object-type (C-next-type-name)))
(apply-decoder reader next-object-type)))
(defun add-writer (reader type-no type-name writer-fn)
(add-encoder reader type-no type-name writer-fn))
(defun add-reader (reader type-no type-name writer-fn)
(add-decoder reader type-no type-name writer-fn))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Readers and writers for vectors and lists. ;;;;
;;;; These should be used as default (they are, in any case, ;;;;
;;;; portable). ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;(declaim (inline ok-message-type))
(proclaim '(inline ok-message-type))
(defun ok-message-type (rdr type-no)
(known-type-number-p rdr type-no))
;;;
;;; Writer (encoder) for vectors.
;;; Vectors must be of type SIMPLE-VECTOR.
;;;
(defun encode-vector (vec objreader)
(let ((len (length vec))) ;; get the length for the header.
;; call the C primitive for stuffing the length
;; into the PVM buffer
(C-obuffer-vector-header len)
;; iterate over the vector, encoding each item and
;; stuffing it into the buffer.
(dotimes (i len)
(apply-encoder objreader (aref vec i)))
;; when control drops out of the bottom of this loop,
;; the vector has been encoded.
))
;;;
;;; Reader (decoder) for vectors.
;;;
(defun decode-vector (objreader)
;; we know we have a vector, so get the length by
;; calling the C primitive.
(let ((vector-len (C-ibuffer-vector-length)))
(cond ((minusp vector-len)
(error "Cannot read vector: negative length ~d~%"
vector-len))
((zerop vector-len)
(make-array '(0)))
(t
(let ((vec (make-array (list vector-len))))
;; create a new vector and try to fill its elements
(dotimes (i vector-len)
(let ((next-obj-type ;; get the type of the next
;; object to be decoded from a C
;; routine
(C-next-msg-type)))
(when (not (ok-message-type objreader next-obj-type))
;; call a routine to check that there is an object
;; that comes next.
(error "Cannot read vector: invalid type ~s~%"
next-obj-type))
(when (message-start-p next-obj-type)
(setq next-obj-type (C-next-type-name)))
(let ((next-elem (apply-decoder objreader next-obj-type)))
(setf (aref vec i) next-elem))))
vec)))))
;;;
;;; Writer (encoder) for lists.
;;; Lists must be PROPER lists.
;;;
(defun encode-list (list-to-go objreader)
;; First ensure that we have a proper list.
(unless (proper-listp list-to-go)
(error
"encode-list: input list is not proper~% ~s ~%-- cannot encode, sorry.~%"
list-to-go))
;; The list header should have been put into the output buffer.
;; Remember that the end of the list has to be a nil message object.
;; So: mark the object to go as a list by calling the C routine.
;; (Perhaps the length could also be encoded for extra checking---
;; perhaps not.)
;; OK. Run over the list and encode the elements.
(C-obuffer-list-header)
(mapc ; or dolist or explicit manipulation---it doesn't matter
#'(lambda (element)
(apply-encoder objreader element))
list-to-go)
;; finally, put a NIL into the output buffer to say that it's the
;; end: do this by calling the C routine.
(C-obuffer-nil)
(values))
;;;
;;; Reader (decoder) for lists.
;;;
(defun decode-list (objreader)
;; When we're called, we know we have a list.
;; We need to iterate until we get a nil object.
;; (Problem: what happens if there is no nil at the end??)
(let ((newlist ()) ;; the list we're going to build.
(next-item-type ())) ;; the type of the next object in the
;; input buffer
(loop
(setq next-item-type (C-next-msg-type))
(when (not (ok-message-type objreader next-item-type))
(error "cannot decode list: invalid type ~s~%"
next-item-type))
(cond ((= next-item-type LISP_NIL_TYPE)
(return)) ; got the end of the list.
((message-start-p next-item-type)
(setq next-item-type (C-next-type-name))
(push (apply-decoder objreader next-item-type) newlist))
(t
(push (apply-decoder objreader next-item-type) newlist))))
(reverse newlist)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; An example of how to define a reader and a writer for a ;;;;
;;;; structure (the same outline applies to classes). ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
#|
(defparameter *rdr* (make-object-reader))
(defstruct foo slot1 slot2)
(defconstant foo-type 32)
(defun write-foo (obj rdr)
(write-object (foo-slot1 obj) rdr)
(write-object (foo-slot2 obj) rdr))
(defun read-foo (rdr)
(let ((s1 (read-object rdr))
(s2 (read-object rdr)))
(make-foo :slot1 s1 :slot2 s2)))
(add-writer *rdr* foo-type 'foo #'write-foo)
(add-reader *rdr* foo-type 'foo #'read-foo)
|#

2062
contrib/thread.patch
View file

File diff suppressed because it is too large Load diff