src/glisp/dep-openmcl.lisp

   1 BABYL OPTIONS: -*- rmail -*-
   2 Version: 5
   3 Labels:
   4 Note:   This is the header of an rmail file.
   5 Note:   If you are seeing it in rmail,
   6 Note:    it means the file has no messages in it.
   7 \x1f\f
   8 1,,
   9 X-From-Line: splittist@yahoo.com Thu Aug 25 15:53:13 2005
  10 Return-path: <splittist@yahoo.com>
  11 Envelope-to: real-csr21@localhost
  12 Delivery-date: Thu, 25 Aug 2005 15:53:13 +0100
  13 Received: from [127.0.0.1] (helo=localhost)
  14         by mu with esmtp (Exim 4.52)
  15         id 1E8J6P-0003Ya-6b
  16         for real-csr21@localhost; Thu, 25 Aug 2005 15:53:13 +0100
  17 Received: from imap.hermes.cam.ac.uk [131.111.8.159]
  18         by localhost with IMAP (fetchmail-6.2.5.1)
  19         for real-csr21@localhost (single-drop); Thu, 25 Aug 2005 15:53:13 +0100 (BST)
  20 Received: from ppsw-9-intramail.csi.cam.ac.uk ([192.168.128.139])
  21         by cyrus-5.csi.private.cam.ac.uk (Cyrus v2.1.16-HERMES)
  22         with LMTP; Thu, 25 Aug 2005 15:47:51 +0100
  23 X-Sieve: CMU Sieve 2.2
  24 X-Cam-SpamScore: ss
  25 X-Cam-SpamDetails: scanned, SpamAssassin (score=2.174,
  26         FORGED_YAHOO_RCVD 2.17)
  27 X-Cam-AntiVirus: No virus found
  28 X-Cam-ScannerInfo: http://www.cam.ac.uk/cs/email/scanner/
  29 Received: from cmailg1.svr.pol.co.uk ([195.92.195.171]:3765)
  30         by ppsw-9.csi.cam.ac.uk (mx.cam.ac.uk [131.111.8.149]:25)
  31         with esmtp (csa=unknown) id 1E8J16-0005kv-Tr (Exim 4.51) for csr21@cam.ac.uk
  32         (return-path <splittist@yahoo.com>); Thu, 25 Aug 2005 15:47:44 +0100
  33 Received: from user-2261.l2.c5.dsl.pol.co.uk ([81.76.40.213] helo=[192.168.1.26])
  34         by cmailg1.svr.pol.co.uk with esmtp (Exim 4.41)
  35         id 1E8J12-0007ZL-9M; Thu, 25 Aug 2005 15:47:40 +0100
  36 X-Gnus-Mail-Source: file:/var/mail/csr21
  37 Message-ID: <430DDA0B.3010307@yahoo.com>
  38 Date: Thu, 25 Aug 2005 15:47:39 +0100
  39 From: John Q Splittist <splittist@yahoo.com>
  40 User-Agent: Mozilla Thunderbird 1.0.6 (Macintosh/20050716)
  41 X-Accept-Language: en-us, en
  42 MIME-Version: 1.0
  43 To:  closure-devel@common-lisp.net
  44 CC: Christophe Rhodes <csr21@cam.ac.uk>
  45 Subject: Openmcl patches
  46 Content-Type: multipart/mixed;
  47  boundary="------------030203070203000802030803"
  48 Lines: 285
  49 Xref: mu list.closure-devel:8
  50
  51 *** EOOH ***
  52 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
  53 ;;; ---------------------------------------------------------------------------
  54 ;;;     Title: OpenMCL dependent stuff + fixups
  55 ;;;   Created: 2005-08-25 11:50
  56 ;;;    Author:
  57 ;;;   License: MIT style (see below)
  58 ;;; ---------------------------------------------------------------------------
  59 ;;;  (c) copyright 1999 by Gilbert Baumann
  60
  61 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  62 ;;;  a copy of this software and associated documentation files (the
  63 ;;;  "Software"), to deal in the Software without restriction, including
  64 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  65 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  66 ;;;  permit persons to whom the Software is furnished to do so, subject to
  67 ;;;  the following conditions:
  68 ;;;
  69 ;;;  The above copyright notice and this permission notice shall be
  70 ;;;  included in all copies or substantial portions of the Software.
  71 ;;;
  72 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  73 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  74 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  75 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  76 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  77 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  78 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  79
  80 (export 'glisp::read-byte-sequence :glisp)
  81 (export 'glisp::read-char-sequence :glisp)
  82 (export 'glisp::run-unix-shell-command :glisp)
  83
  84 (export 'glisp::getenv :glisp)
  85
  86 (export 'glisp::make-server-socket :glisp)
  87 (export 'glisp::close-server-socket :glisp)
  88
  89 (defun glisp::read-byte-sequence (&rest ap)
  90   (apply #'read-sequence ap))
  91
  92 (defun glisp::read-char-sequence (&rest ap)
  93   (apply #'read-sequence ap))
  94
  95 (defmacro glisp::with-timeout ((&rest options) &body body)
  96   (declare (ignore options))
  97   `(progn
  98      ,@body))
  99
 100 (defun glisp::open-inet-socket (hostname port)
 101   (values
 102    (ccl::make-socket :address-family :internet
 103                      :type :stream
 104                      :remote-host hostname
 105                      :remote-port port)
 106    :byte))
 107
 108 (defstruct (server-socket (:constructor make-server-socket-struct))
 109   fd
 110   element-type
 111   port)
 112
 113
 114 #||
 115 (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
 116   (make-server-socket-struct :fd (ext:create-inet-listener port)
 117                              :element-type element-type
 118                              :port port))
 119
 120
 121 (defun glisp::accept-connection/low (socket)
 122   (mp:process-wait-until-fd-usable (server-socket-fd socket) :input)
 123   (values
 124    (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket))
 125                        :input t :output t
 126                        :element-type (server-socket-element-type socket))
 127    (cond ((subtypep (server-socket-element-type socket) 'integer)
 128           :byte)
 129          (t
 130           :char))))
 131
 132 (defun glisp::close-server-socket (socket)
 133   (unix:unix-close (server-socket-fd socket)))
 134 ||#
 135
 136 ;;;;;;
 137
 138 (defun glisp::g/make-string (length &rest options)
 139   (apply #'make-array length :element-type 'base-char options))
 140
 141
 142
 143 (defun glisp::run-unix-shell-command (command)
 144   (nth-value 1 (ccl:external-process-status
 145    (ccl:run-program "/bin/sh" (list "-c" command) :wait t :input nil
 146                        :output nil))))
 147
 148 ;;; MP
 149
 150 (export 'glisp::mp/process-yield :glisp)
 151 (export 'glisp::mp/process-wait :glisp)
 152 (export 'glisp::mp/process-run-function :glisp)
 153 (export 'glisp::mp/make-lock :glisp)
 154 (export 'glisp::mp/current-process :glisp)
 155 (export 'glisp::mp/process-kill :glisp)
 156
 157 (defun glisp::mp/make-lock (&key name)
 158   (clim-sys::make-lock name))
 159
 160 (defmacro glisp::mp/with-lock ((lock) &body body)
 161   `(clim-sys:with-lock-held (,lock)
 162     ,@body))
 163
 164 (defun glisp::mp/process-yield (&optional process-to-run)
 165   (declare (ignore process-to-run))
 166   (clim-sys:process-yield))
 167
 168 (defun glisp::mp/process-wait (whostate predicate)
 169   (clim-sys:process-wait whostate predicate))
 170
 171 (defun glisp::mp/process-run-function (name fun &rest args)
 172   (clim-sys:make-process
 173    (lambda ()
 174      (apply fun args))
 175    :name name))
 176
 177 (defun glisp::mp/current-process ()
 178   (clim-sys:current-process))
 179
 180 (defun glisp::mp/process-kill (process)
 181   (clim-sys:destroy-process process))
 182
 183 (defun glisp::getenv (string)
 184   (ccl::getenv string))
 185 \x1f