src/glisp/dep-acl5.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; Encoding: utf-8; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: ACL-5.0 dependent stuff + fixups
   4 ;;;   Created: 1999-05-25 22:32
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1998,1999 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 ;;; Changes
  30 ;;; =======
  31
  32 ;;; When        Who     What
  33 ;;; ---------------------------------------------------------------------------
  34 ;;; 2002-01-04  GB      spend BLOCK for DEFSUBST
  35 ;;; 1999-08-31  SES     Stig Erik Sandø <stig@ii.uib.no>
  36 ;;;
  37 ;;;                     Changed #+allegro-v5.0 to
  38 ;;;                     #+(and allegro-version>= (version>= 5))
  39 ;;;
  40
  41 (export 'glisp::read-byte-sequence :glisp)
  42 (export 'glisp::read-char-sequence :glisp)
  43 (export 'glisp::run-unix-shell-command :glisp)
  44 (export 'glisp::mp/process-run-function :glisp)
  45 (export 'glisp::mp/process-kill :glisp)
  46 (export 'glisp::mp/current-process :glisp)
  47 (export 'glisp::mp/seize-lock :glisp)
  48 (export 'glisp::mp/release-lock :glisp)
  49 (export 'glisp::mp/process-yield :glisp)
  50 (export 'glisp::mp/process-wait :glisp)
  51 (export 'glisp::getenv :glisp)
  52
  53 (export 'glisp::make-server-socket :glisp)
  54
  55 (defun glisp::mp/seize-lock (lock &key whostate)
  56   whostate
  57   (mp:process-lock lock))
  58
  59 (defun glisp::mp/release-lock (lock)
  60   (mp:process-unlock lock))
  61
  62 (defun glisp::read-byte-sequence (&rest ap)
  63   (apply #'read-sequence ap))
  64
  65 (defun glisp::read-char-sequence (&rest ap)
  66   (apply #'read-sequence ap))
  67
  68 #+(and allegro-version>= (version>= 5))
  69 (defun glisp::open-inet-socket (hostname port)
  70   (values
  71    (socket:make-socket :remote-host hostname
  72                        :remote-port port
  73                        :format :binary)
  74    :byte))
  75
  76 (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
  77   (socket:make-socket :connect :passive
  78                       :local-port port
  79                       :format (cond ((subtypep element-type '(unsigned-byte 8))
  80                                      :binary)
  81                                     ((subtypep element-type 'character)
  82                                      :text)
  83                                     (t
  84                                      (error "Unknown element type: ~S." element-type)))))
  85
  86 (defun glisp::accept-connection/low (socket)
  87   (values
  88    (socket:accept-connection socket :wait t)
  89    :byte))
  90
  91
  92 #-(and allegro-version>= (version>= 5))
  93 (defun glisp::open-inet-socket (hostname port)
  94   (values
  95    (ipc:open-network-stream :host hostname
  96                             :port port
  97                             :element-type '(unsigned-byte 8)
  98                             :class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
  99    :byte))
 100
 101 (defun glisp::mp/make-lock (&key name)
 102   (mp:make-process-lock :name name))
 103
 104 (defmacro glisp::mp/with-lock ((lock) &body body)
 105   `(mp:with-process-lock (,lock)
 106      ,@body))
 107
 108 (defmacro glisp::with-timeout ((&rest options) &body body)
 109   `(mp:with-timeout ,options . ,body))
 110
 111 (defun glisp::g/make-string (length &rest options)
 112   (apply #'make-array length :element-type 'base-char options))
 113
 114 (defun glisp:run-unix-shell-command (cmd)
 115   (excl:shell cmd))
 116
 117 (defparameter glisp::*inherited-vars*
 118     '(*terminal-io* *standard-input* *standard-output* *error-output* *trace-output* *query-io* *debug-io*))
 119
 120 (defparameter glisp::*inherited-vars* nil)
 121
 122 (defun glisp:mp/process-run-function (name fn &rest args)
 123   (mp:process-run-function
 124    name
 125    (lambda (vars vals fn args)
 126      (progv vars vals
 127        (apply fn args)))
 128    glisp::*inherited-vars* (mapcar #'symbol-value glisp::*inherited-vars*)
 129    fn args))
 130
 131 (defun glisp:mp/current-process ()
 132   sys:*current-process*)
 133
 134 (defun glisp::mp/process-yield (&optional process-to-run)
 135   (mp:process-allow-schedule process-to-run))
 136
 137 (defun glisp::mp/process-wait (whostate predicate)
 138   (mp:process-wait whostate predicate))
 139
 140 (defun glisp::mp/process-kill (proc)
 141   (mp:process-kill proc))
 142
 143 (defun glisp::getenv (string)
 144   (sys:getenv string))