Permalink
Switch branches/tags
save2011_02_16 release10.1_t6 release10.1_t5 release10.1_t4 release10.1_t3 release10.1_t2 release10.1_t1 release10.1_release_point release10.1_rc5 release10.1_rc4 release10.1_rc3 release10.1_rc2 release10.1_rc1 release10.1_beta3_release_point release10.1.beta2_release_point release10.1.beta_t6 release10.1.beta_t5 release10.1.beta_t4 release10.1.beta_t3 release10.1.beta_t2 release10.1.beta_t1 release10.1.beta_release_point release10.1.beta_rc4 release10.1.beta_rc3 release10.1.beta_rc2 release10.1.beta_rc1 release10.0_t3 release10.0_t2 release10.0_t1 release10.0_rc9 release10.0_rc8 release10.0_rc7 release10.0_rc6 release10.0_rc5 release10.0_rc4 release10.0_rc3 release10.0_rc2 release10.0_rc1 release10.0.pre-final.30_release_point release10.0.pre-final.17_release_point release10.0.beta_t13 release10.0.beta_t12 release10.0.beta_t11 release10.0.beta_t10 release10.0.beta_t9 release10.0.beta_t8 release10.0.beta_t7 release10.0.beta_t6 release10.0.beta_t5 release10.0.beta_t4 release10.0.beta_t3 release10.0.beta_t2 release10.0.beta_t1 release10.0.beta_release_point release10.0.beta_rc2 release10.0.beta_rc1 release_aclt2 release_acl100b14t8 release_acl100b11t7 release_acl100b10t6 release_acl100b8t5 release_acl100b7t4 release_acl100b6t3 release_acl100b4t2 release_acl100b2t1 release_acl90b21rc5 release_acl90b20_release_point release_acl90b20rc4 release_acl90b19rc3 release_acl90b18rc2 release_acl90b15_release_point release_acl90b15rc1 release_acl90b13t1 release_acl90b11t1 release_acl90b9t1 release_acl90b8t1 release_acl90b6_release_point release_acl90b6rc2 release_acl90b_release_point release_acl90a52rc1 release_acl90a44rc2 release_acl90a43rc1 release_acl90a39 release_acl90a39rc2 release_acl90a32 release_acl90a27 release_acl90a25 release_acl90a24 release_acl90a23 release_acl90a20 release_acl90a18 install-spider_2013-04-26T12-55-31 install-spider_2013-04-25T12-56-58 install-spider_2013-04-24T16-52-55 install-spider_2013-04-24T16-42-42 install-spider_2013-04-24T16-29-36 install-spider_2013-04-24T15-47-16 install-spider_2013-04-24T15-37-01 install-spider_2013-04-24T15-02-09 install-spider_2013-04-23T11-10-35
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
324 lines (260 sloc) 8.55 KB
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; macs.cl
;;
;; See the file LICENSE for the full license governing this code.
;;
;;
;; Description:
;; useful internal macros
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
;; macros used by iserve
(in-package :net.aserve)
;; add features based on the capabilities of the host lisp
#+(version>= 6 1) (pushnew :io-timeout *features*) ; support i/o timeouts
;; Note for people using this code in non-Allegro lisps.
;;
;; The if* macro used in this code can be found at:
;;
;; http://www.franz.com/~jkf/ifstar.txt
;;
;; macros to speed up some common character operations
(defmacro find-it (ch buff start end)
;; return position of ch in buff from [start end}
;;
(let ((pos (gensym)))
`(do ((,pos ,start (1+ ,pos)))
((>= ,pos ,end))
(if* (eq (schar ,buff ,pos) ,ch)
then (return ,pos)))))
(defmacro find-it-rev (ch buff start end)
;; return position of ch in buff from [start end}
;; searching backwards
;;
(let ((pos (gensym)))
`(do ((,pos (1- ,end) (1- ,pos)))
((< ,pos ,start))
(if* (eq (schar ,buff ,pos) ,ch)
then (return ,pos)))))
(defmacro buffer-substr (buff start end)
;; return a string holding the chars in buff from [start end }
;;
(let ((res (gensym))
(i (gensym))
(pos (gensym)))
`(let ((,res (make-string (- ,end ,start))))
(do ((,i 0 (1+ ,i))
(,pos ,start (1+ ,pos)))
((>= ,pos ,end))
(setf (schar ,res ,i) (schar ,buff ,pos)))
,res)))
(defmacro buffer-match (buff start str)
;; return t if the buffer buff contains the same string as str
(let ((pos (gensym))
(i (gensym))
(len (gensym)))
`(do ((,pos ,start (1+ ,pos))
(,i 0 (1+ ,i))
(,len (length ,str)))
((>= ,i ,len) t)
(if* (not (eq (schar ,buff ,pos) (schar ,str ,i)))
then (return nil)))))
(defmacro buffer-match-ci (buff start str)
;; return t if the buffer buff contains the same string as str
;; case insensitive version where str contains each char doubled
(let ((pos (gensym))
(i (gensym))
(len (gensym))
(xchar (gensym)))
`(do ((,pos ,start (1+ ,pos))
(,i 0 (+ 2 ,i))
(,len (length ,str)))
((>= ,i ,len) t)
(let ((,xchar (schar ,buff ,pos)))
(if* (not (or (eq ,xchar (schar ,str ,i))
(eq ,xchar (schar ,str (1+ ,i)))))
then (return nil))))))
(defmacro rational-read-sequence (&rest args)
;; acl's read-sequence was changed to conform to the
;; bogus ansi definition where the whole buffer was filled up.
;; even for socket stream.
;; rational-read-sequence does read-sequence the right way.
#-(version>= 6 0 pre-final 9)
`(read-sequence ,@args)
#+(version>= 6 0 pre-final 9)
`(read-sequence ,@args :partial-fill t))
;;;; response macros
;---- unsigned byte 8 array macros:
(defmacro ausb8 (vec index)
; like aref but it declares the type
`(aref (the (simple-array (unsigned-byte 8) 1) ,vec) ,index))
(defmacro copy-usb8 (from-vector from-start
to-vector to-start
count)
;; copy count bytes from from-vector[start] to to-vector[start].
;; vectors are usb8
(let ((from (gensym))
(to (gensym))
(i (gensym)))
`(do ((,from ,from-start (1+ ,from))
(,to ,to-start (1+ ,to))
(,i ,count (1- ,i)))
((<= ,i 0))
(setf (ausb8 ,to-vector ,to)
(ausb8 ,from-vector ,from)))))
(defmacro copy-usb8-up (from-vector from-start
to-vector to-start
count)
;; copy count bytes from from-vector[start] to to-vector[start],
;; going from the top down. this is designed to be used if we are
;; copying upward in place so we have to copy from the top down
;;
;; vectors are usb8
(let ((from (gensym))
(to (gensym))
(i (gensym)))
`(do* ((,i ,count (1- ,i))
(,from (+ ,from-start ,i -1) (1- ,from))
(,to (+ ,to-start ,i -1) (1- ,to)))
((<= ,i 0))
(setf (ausb8 ,to-vector ,to)
(ausb8 ,from-vector ,from)))))
;-------------
(defmacro dlogmess (&rest args)
;; for now we just disable completely the log messages.
;; in the future we'll turn on and off the log messages
;; at runtime with a switch.
(declare (ignore args))
nil)
;---------------
; acl 6.1 and newer support timeouts on read/write for hiper streams
; Thus we can avoid using global timeouts in certain cases.
;
; with-timeout-local: use with-timeout if that all we've got
; else use read-write timeouts
;
#-(version>= 6 1)
(defmacro with-timeout-local ((time &rest actions) &body body)
;; same as with-timeout
`(mp:with-timeout (,time ,@actions) ,@body)) ; ok w-t
#+(version>= 6 1)
(defmacro with-timeout-local ((time &rest actions) &body body)
(declare (ignore time))
(let ((g-blocktag (gensym)))
`(block ,g-blocktag
(handler-bind ((socket-error
#'(lambda (c)
(if* (member (stream-error-identifier c)
'(:read-timeout :write-timeout)
:test #'eq)
then ; must handle this
(return-from ,g-blocktag
(progn ,@actions))))))
,@body))))
;;;;;;;;;;;;;; SMP-aware macros
;;
;; We cater to three slightly different states:
;;
;; #+smp
;; (smp-case (t form) ...)
;; The compile and execute environments support SMP;
;; 9.0 with smp.
;;
;; #+(and smp-macros (not smp))
;; (smp-case (:macros form) ...)
;; Compile environment recognizes the SMP macros, but compiles
;; for non-SMP lisp;
;; >=8.2 but not smp
;; 8.1 with smp patches.
;;
;; #-smp-macros
;; (smp-case (nil form) ...)
;; Compile environment does not recognize SMP macros;
;; 8.1 without smp patches.
;;
(defmacro smp-case (&rest clauses)
(let* ((key
#+smp t
#+(and smp-macros (not smp)) :macros
#-smp-macros nil
)
(clause (dolist (c clauses)
(if* (not (and (consp c)
(consp (cdr c))
(null (cddr c))))
then (error "smp-case clause ~s is badly formed" c))
(let ((c-key (car c)))
(if* (or (eq c-key key)
(and (consp c-key)
(member key c-key)))
then (return c))))))
(if* (not clause)
then (error "smp-case is missing clause for ~s" key))
(second clause)))
(defmacro check-smp-consistency ()
(smp-case
(nil (if* (featurep :smp)
then (error "This file was compiled to run in a non-smp acl")))
(:macros (if* (featurep :smp)
then (error "This file was compiled to run in a non-smp acl")
elseif (not (featurep :smp-macros))
then (error "This file requires the smp-macros patch")))
(t (if* (not (featurep :smp))
then (error "This file was compiled to run in an smp acl")))))
(defmacro atomic-incf (var)
(smp-case
(t `(incf-atomic ,var))
(:macros `(with-locked-object (nil :non-smp :without-scheduling) (incf ,var)))
(nil `(si:without-scheduling (incf ,var))))
)
(defmacro atomic-decf (var)
(smp-case
(t `(decf-atomic ,var))
(:macros `(with-locked-object (nil :non-smp :without-scheduling) (decf ,var)))
(nil `(si:without-scheduling (decf ,var)))))
(defmacro with-locked-server ((s) &body body)
(smp-case
((t :macros) `(with-locked-object (,s :non-smp :without-scheduling) ,@body))
(nil `(si:without-scheduling ,s ,@body))))
(defmacro defvar-mp (v &rest rest)
(smp-case
((t :macros) `(defvar-nonbindable ,v ,@rest))
(nil `(defvar ,v ,@rest))))
(defmacro atomically-fast (&body body)
(smp-case
((t :macros) `(excl::.atomically (excl::fast ,@body)))
(nil `(excl::atomically (excl::fast ,@body)))))
(defmacro atomic-setf-max (place val)
(smp-case
(nil (let ((newvar (gensym)))
`(let ((,newvar ,val))
(without-interrupts
(if* (< ,place ,newvar) then (setf ,place ,newvar) t)))))
((t :macros) (let ((newvar (gensym)) (oldvar (gensym)))
`(let ((,newvar ,val) ,oldvar)
(loop
(setq ,oldvar ,place)
(cond ((not (< ,oldvar ,newvar)) (return nil))
((atomic-conditional-setf ,place ,newvar ,oldvar)
(return t)))))))))
;;;;;; end of smp-aware macro definitions
(define-condition allegroserve-error (error)
(;; what was being attempted with the error occured
(action :initarg :action :reader allegroserve-error-action
:initform "unspecified")
;; describing the result that is considered an error
(result :initarg :result :reader allegroserve-error-result
:initform "unspecified")
; a keyword unique to each error
(identifier :initarg :identifier :reader allegroserve-error-identifier
:initform nil))
(:report
(lambda (con stream)
(with-slots (action result identifier) con
(format stream
"~@<~a resulted in error ~s : ~a.~:@>"
action
identifier
result)))))