/[gcl]/gcl/pargcl/src/slave-listener.lsp
ViewVC logotype

Diff of /gcl/pargcl/src/slave-listener.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by gene, Sat Nov 5 09:37:02 2005 UTC revision 1.5 by gene, Sun Nov 6 09:35:25 2005 UTC
# Line 21  Line 21 
21  ;;;; (send-message <lisp-expr> <optional dest = 1>)  ;;;; (send-message <lisp-expr> <optional dest = 1>)
22  ;;;; (broadcast-message <lisp-expr>) ; no reply message  ;;;; (broadcast-message <lisp-expr>) ; no reply message
23  ;;;; (receive-message <optional source = (MPI-Any-source)>)  ;;;; (receive-message <optional source = (MPI-Any-source)>)
 ;;;; (defun send-receive-message <lisp-expr> <optional dest = 1>)  
24  ;;;; (send-receive-message <lisp-expr> <optional dest = 1>)  ;;;; (send-receive-message <lisp-expr> <optional dest = 1>)
25  ;;;; (free-msg-buffer <buf>) ; optimization for greater efficiency, only  ;;;; (free-msg-buffer <buf>) ; optimization for greater efficiency, only
26  ;;;;                         ; frees message buffer for re-use in next MPI-recv  ;;;;                         ; frees message buffer for re-use in next MPI-recv
# Line 152  Line 151 
151    (MPI-Send message dest tag)    (MPI-Send message dest tag)
152    nil)    nil)
153    
154  ;;; Still writing this.  (defun fix-read-write-consistency (str &aux preamble-begin preamble-end end)
155  ;;; must handle #'foo => (lambda-block ...)    "Change #<compiled-function ...> and #<interpreted-function ...> to #'...
156  ;;;   and #'(lambda ...) => (lambda-closure () () () ...)     Works solely by modifying str argument"
157  #- not-a-feature    (setq preamble-begin (si:string-match "#<[a-z]*-function " str))
158  (defun fix-read-write-consistency (str) str)    (if (= preamble-begin -1) (return-from fix-read-write-consistency str))
159  #+ not-a-feature    ;; CHANGE:  '#<...>   ==>   #<...>
160  (defun fix-read-write-consistency (str)    ;;   since later,  #<...> become #'(lambda (...) ...)
161    "Change #<compiled-function ...> and #<interpreted-function ...> to #'..."    ;; Presumably, other special functions, besides "quote" could also be a problem.
162    ;; This doesn't work if ">" (greater than) is used as a function.    (if (and (> preamble-begin 0) (eq (aref str (- preamble-begin 1)) #\'))
163    ;; Really have to use "read-from-string" and be prepared to catch error.        (setf (aref str (- preamble-begin 1)) #\space))
164        (setq a (si:string-match "#<[a-z]*-function "))    (setq preamble-end (si:match-end 0))
165        (setq b (si:match-end 0))    (fix-read-write-consistency
166        (setq c (length (format nil "~a" (read-from-string      (make-array (- (length str) preamble-end)
167          (make-array :element-type 'character                  :element-type (array-element-type str)
168                      :displaced-to str                  :displaced-to str
169                      :displaced-index-offset (si:match-end 0))))))                  :displaced-index-offset preamble-end))
170        (setf (aref str a) #\' ) ; #< ==> #'    (multiple-value-bind (expr expr-end)
171        (fill str #\space :start (+ a 1) :end b) ; ...-function ==> _spaces_                         (read-from-string str t nil :start preamble-end)
172        (if lambda-block rewrite it or macroexpand it)      (loop (if (memq (aref str (- expr-end 1)) '(#\tab #\newline #\space))
173        (setf (aref str (+ b c)) #\) ) ; > ==> right_paren              (decf expr-end)
174    si:match-end              (return)))
175    si:match-beginning      (when (eq #\> (aref str (1- expr-end))) ; when: #<compiled-function mapcar>
176  )        (decf expr-end)
177          (setq expr (read-from-string str t nil :start preamble-end :end expr-end)))
178        (setq end (1+ (si:string-match ">" str expr-end))) ; start at expr-end
179        ;; fill with spaces following '#' of '#<...>'
180        (fill str #\space :start (+ preamble-begin 1) :end end)
181        (setf (aref str (+ preamble-begin 1)) #\' ) ; #<   ==>   #'
182        (with-output-to-string (stream
183                                 (make-array (- (length str) preamble-begin 2)
184                                             :fill-pointer 0
185                                             :element-type (array-element-type str)
186                                             :displaced-to str
187                                     :displaced-index-offset (+ preamble-begin 2)))
188          (write (cond ((not (listp expr)) expr)
189                       ;; (lambda-block (x) (+ x 1)) =>
190                       ((eq (first expr) 'lambda-block)
191                        (list 'lambda (third expr)
192                              (list* 'block (second expr) (cdddr expr))))
193                       ;; (lambda-closure () () () (x) (+ x 1)) =>
194                       ((eq (first expr) 'lambda-closure)
195                        (cons 'lambda (cddddr expr))))
196                 ;; :circle t okay; body of fnc shouldn't be so large to blow stack
197                 :stream stream :escape t :level nil :length nil :array t :circle t
198                 )))
199      str)
200    
201  (defun receive-message (&optional (source (MPI-Any-source)) (tag (MPI-Any-tag))  (defun receive-message (&optional (source (MPI-Any-source)) (tag (MPI-Any-tag))
202                               &aux (datatype -10) (type-enum -1) (type NIL)                               &aux (datatype -10) (type-enum -1) (type NIL)

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26