177 lines
5.1 KiB
Common Lisp
177 lines
5.1 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Title: CLISP dependent stuff + fixups
|
|
;;; Created: 1999-05-25 22:32
|
|
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
|
;;; License: GPL (See file COPYING for details).
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; (c) copyright 1999 by Gilbert Baumann
|
|
|
|
;;; This program is free software; you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 2 of the License, or
|
|
;;; (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program; if not, write to the Free Software
|
|
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
|
|
(in-package :CL-USER)
|
|
|
|
(eval-when (compile load eval)
|
|
(if (fboundp 'cl::define-compiler-macro)
|
|
(pushnew 'define-compiler-macro *features*)))
|
|
|
|
(setq lisp:*load-paths* '(#P"./"))
|
|
|
|
(import 'lisp:read-byte-sequence :glisp)
|
|
(export 'lisp:read-byte-sequence :glisp)
|
|
(import 'lisp:read-char-sequence :glisp)
|
|
(export 'lisp:read-char-sequence :glisp)
|
|
(export 'glisp::compile-file :glisp)
|
|
(export 'glisp::run-unix-shell-command :glisp)
|
|
(export 'glisp::make-server-socket :glisp)
|
|
|
|
|
|
#||
|
|
(export 'glisp::read-byte-sequence :glisp)
|
|
(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
|
|
(let (c (i start))
|
|
(loop
|
|
(cond ((= i end) (return i)))
|
|
(setq c (read-byte input nil :eof))
|
|
(cond ((eql c :eof) (return i)))
|
|
(setf (aref sequence i) c)
|
|
(incf i) )))
|
|
||#
|
|
|
|
|
|
(defun glisp::compile-file (&rest ap)
|
|
(and (apply #'compile-file ap)
|
|
(apply #'compile-file-pathname ap)))
|
|
|
|
(defmacro glisp::with-timeout ((&rest ignore) &body body)
|
|
(declare (ignore ignore))
|
|
`(progn
|
|
,@body))
|
|
|
|
(defun glisp::open-inet-socket (hostname port)
|
|
(values
|
|
(lisp:socket-connect port hostname)
|
|
:byte))
|
|
|
|
(defun glisp:make-server-socket (port)
|
|
(lisp:socket-server port))
|
|
|
|
(defun glisp::accept-connection/low (socket)
|
|
(let ((stream (lisp:socket-accept socket)))
|
|
(setf (stream-element-type stream) '(unsigned-byte 8))
|
|
(values
|
|
stream
|
|
:byte)))
|
|
|
|
(defun glisp::g/make-string (length &rest options)
|
|
(apply #'make-array length
|
|
:element-type
|
|
'#.(cond ((stringp (make-array 1 :element-type 'string-char))
|
|
'string-char)
|
|
((stringp (make-array 1 :element-type 'base-char))
|
|
'base-char)
|
|
(t
|
|
(error "What is the string element type of the day?")))
|
|
options))
|
|
|
|
(defun glisp:run-unix-shell-command (command)
|
|
(lisp:shell command))
|
|
|
|
#+DEFINE-COMPILER-MACRO
|
|
(cl:define-compiler-macro ldb (bytespec value &whole whole)
|
|
(let (pos size)
|
|
(cond ((and (consp bytespec)
|
|
(= (length bytespec) 3)
|
|
(eq (car bytespec) 'byte)
|
|
(constantp (setq size (second bytespec)))
|
|
(constantp (setq pos (third bytespec))))
|
|
`(logand ,(if (eql pos 0) value `(ash ,value (- ,pos)))
|
|
(1- (ash 1 ,size))))
|
|
(t
|
|
whole))))
|
|
|
|
#-DEFINE-COMPILER-MACRO
|
|
(progn
|
|
(export 'glisp::define-compiler-macro :glisp)
|
|
(defmacro glisp::define-compiler-macro (name args &body body)
|
|
(declare (ignore args body))
|
|
`(progn
|
|
',name)))
|
|
|
|
#||
|
|
(defun xlib:draw-glyph (drawable gcontext x y elt &rest more)
|
|
(apply #'xlib:draw-glyphs drawable gcontext x y (vector elt) more))
|
|
||#
|
|
|
|
(defmacro glisp::defsubst (name args &body body)
|
|
`(progn
|
|
(declaim (inline ,name))
|
|
(defun ,name ,args .,body)))
|
|
|
|
(export 'glisp::getenv :glisp)
|
|
(defun glisp::getenv (var)
|
|
(sys::getenv var))
|
|
|
|
|
|
|
|
(export 'glisp::mp/process-run-function :glisp)
|
|
(defun glisp:mp/process-run-function (name fn &rest args)
|
|
(apply #'mp:process-run-function name fn args))
|
|
|
|
(export 'glisp::mp/process-kill :glisp)
|
|
(defun glisp:mp/process-kill (proc)
|
|
(mp:process-kill proc))
|
|
|
|
(export 'glisp::mp/current-process :glisp)
|
|
(defun glisp:mp/current-process ()
|
|
(mp:current-process))
|
|
|
|
(export 'glisp::mp/seize-lock :glisp)
|
|
(defun glisp::mp/seize-lock (lock &key whostate)
|
|
whostate
|
|
(mp:process-lock lock))
|
|
|
|
(export 'glisp::mp/release-lock :glisp)
|
|
(defun glisp::mp/release-lock (lock)
|
|
(mp:process-unlock lock))
|
|
|
|
(export 'glisp::mp/process-yield :glisp)
|
|
(defun glisp::mp/process-yield (&optional process-to-run)
|
|
process-to-run
|
|
(mp:process-allow-schedule))
|
|
|
|
(export 'glisp::mp/process-wait :glisp)
|
|
(defun glisp::mp/process-wait (whostate predicate)
|
|
(mp::process-wait whostate predicate))
|
|
|
|
(defmacro glisp::mp/with-lock ((lock) &body body)
|
|
`(mp:with-process-lock (,lock)
|
|
,@body))
|
|
|
|
(defun glisp::mp/make-lock (&key name)
|
|
(mp:make-process-lock :name name))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|