; -*- Mode: Lisp; Package: CCL; -*- ;;; ;;; Copyright (C) 2009 Clozure Associates ;;; Copyright (C) 1994-2001 Digitool, Inc ;;; This file is part of Clozure CL. ;;; ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public ;;; License , known as the LLGPL and distributed with Clozure CL as the ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, ;;; which is distributed with Clozure CL as the file "LGPL". Where these ;;; conflict, the preamble takes precedence. ;;; ;;; Clozure CL is referenced in the preamble as the "LIBRARY." ;;; ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html (in-package "CCL") (defun utf-8-octets-in-string (string start end) (if (>= end start) (do* ((noctets 0) (i start (1+ i))) ((= i end) noctets) (declare (fixnum noctets)) (let* ((code (char-code (schar string i)))) (declare (type (mod #x110000) code)) (incf noctets (if (< code #x80) 1 (if (< code #x800) 2 (if (< code #x10000) 3 4)))))) 0)) (defun utf-16-octets-in-string (string start end) (if (>= end start) (do* ((noctets 0) (i start (1+ i))) ((= i end) noctets) (declare (fixnum noctets)) (let* ((code (char-code (schar string i)))) (declare (type (mod #x110000) code)) (incf noctets (if (< code #x10000) 2 4)))) 0)) (defun utf-8-memory-encode (string pointer idx start end) (declare (fixnum idx)) (do* ((i start (1+ i))) ((>= i end) idx) (let* ((code (char-code (schar string i)))) (declare (type (mod #x110000) code)) (cond ((< code #x80) (setf (%get-unsigned-byte pointer idx) code) (incf idx)) ((< code #x800) (setf (%get-unsigned-byte pointer idx) (logior #xc0 (the fixnum (ash code -6)))) (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) (logior #x80 (the fixnum (logand code #x3f)))) (incf idx 2)) ((< code #x10000) (setf (%get-unsigned-byte pointer idx) (logior #xe0 (the fixnum (ash code -12)))) (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) (logior #x80 (the fixnum (logand code #x3f)))) (incf idx 3)) (t (setf (%get-unsigned-byte pointer idx) (logior #xf0 (the fixnum (logand #x7 (the fixnum (ash code -18)))))) (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) (logior #x80 (logand #x3f code))) (incf idx 4)))))) (defun native-utf-16-memory-encode (string pointer idx start end) (declare (fixnum idx)) (do* ((i start (1+ i))) ((>= i end) idx) (let* ((code (char-code (schar string i))) (highbits (- code #x10000))) (declare (type (mod #x110000) code) (fixnum highbits)) (cond ((< highbits 0) (setf (%get-unsigned-word pointer idx) code) (incf idx 2)) (t (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) (incf idx 2) (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff)))) (incf idx 2)))))) (defun utf-8-memory-decode (pointer noctets idx string) (declare (fixnum noctets idx)) (do* ((i 0 (1+ i)) (end (+ idx noctets)) (index idx (1+ index))) ((>= index end) (if (= index end) index 0)) (let* ((1st-unit (%get-unsigned-byte pointer index))) (declare (type (unsigned-byte 8) 1st-unit)) (let* ((char (if (< 1st-unit #x80) (code-char 1st-unit) (if (>= 1st-unit #xc2) (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) (declare (type (unsigned-byte 8) 2nd-unit)) (if (< 1st-unit #xe0) (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) (code-char (logior (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) (the fixnum (logxor 2nd-unit #x80))))) (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) (declare (type (unsigned-byte 8) 3rd-unit)) (if (< 1st-unit #xf0) (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) (< (the fixnum (logxor 3rd-unit #x80)) #x40) (or (>= 1st-unit #xe1) (>= 2nd-unit #xa0))) (code-char (the fixnum (logior (the fixnum (ash (the fixnum (logand 1st-unit #xf)) 12)) (the fixnum (logior (the fixnum (ash (the fixnum (logand 2nd-unit #x3f)) 6)) (the fixnum (logand 3rd-unit #x3f)))))))) (if (< 1st-unit #xf8) (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) (declare (type (unsigned-byte 8) 4th-unit)) (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) (< (the fixnum (logxor 3rd-unit #x80)) #x40) (< (the fixnum (logxor 4th-unit #x80)) #x40) (or (>= 1st-unit #xf1) (>= 2nd-unit #x90))) (code-char (logior (the fixnum (logior (the fixnum (ash (the fixnum (logand 1st-unit 7)) 18)) (the fixnum (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) (the fixnum (logior (the fixnum (ash (the fixnum (logxor 3rd-unit #x80)) 6)) (the fixnum (logxor 4th-unit #x80))))))))))))))))) (setf (schar string i) (or char (note-vector-decoding-problem pointer index :utf-8))))))) (defun utf-8-length-of-memory-encoding (pointer noctets start) (do* ((i start) (end (+ start noctets)) (nchars 0 (1+ nchars))) ((= i end) (values nchars (- i start))) (let* ((code (%get-unsigned-byte pointer i)) (nexti (+ i (cond ((< code #xc2) 1) ((< code #xe0) 2) ((< code #xf0) 3) ((< code #xf8) 4) (t 1))))) (declare (type (unsigned-byte 8) code)) (if (> nexti end) (return (values nchars (- i start))) (setq i nexti))))) ;;; write nbytes bytes from buffer buf to file-descriptor fd. (defun fd-write (fd buf nbytes) (ignoring-eintr (int-errno-ffcall (%kernel-import target::kernel-import-lisp-write) :int fd :address buf :ssize_t nbytes :ssize_t))) (defun fd-read (fd buf nbytes) (ignoring-eintr (int-errno-ffcall (%kernel-import target::kernel-import-lisp-read) :int fd :address buf :ssize_t nbytes :ssize_t))) (let* ((pathname-encoding-name ())) (declare (ignorable pathname-encoding-name)) (defun pathname-encoding-name () #+darwin-target :utf-8 #+windows-target :utf-16le #-(or darwin-target windows-target) pathname-encoding-name) (defun set-pathname-encoding-name (new) #+(or darwin-target windows-target) (declare (ignore new)) #+darwin-target :utf-8 #+windows-target :utf-16le #-(or darwin-target windows-target) (let* ((encoding (ensure-character-encoding new))) (setq pathname-encoding-name (unless (eq encoding (get-character-encoding nil)) (character-encoding-name encoding)))))) (defun fd-open-path (p flags create-mode) (let* ((fd (int-errno-ffcall (%kernel-import target::kernel-import-lisp-open) :address p :int flags :mode_t create-mode :int))) (declare (fixnum fd)) (when (or (= fd (- #$EMFILE)) (= fd (- #$ENFILE))) (gc) (drain-termination-queue) (setq fd (int-errno-ffcall (%kernel-import target::kernel-import-lisp-open) :address p :int flags :mode_t create-mode :int))) fd)) (defun fd-open (path flags &optional (create-mode #o666)) #+darwin-target (with-utf-8-cstrs ((p path)) (fd-open-path p flags create-mode)) #+windows-target (with-native-utf-16-cstrs ((p path)) (fd-open-path p flags create-mode)) #-(or darwin-target windows-target) (let* ((encoding (pathname-encoding-name))) (if encoding (with-encoded-cstrs encoding ((p path)) (fd-open-path p flags create-mode)) (with-cstrs ((p path)) (fd-open-path p flags create-mode))))) (defun fd-chmod (fd mode) (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fchmod) :int fd :mode_t mode :int)) (defun fd-lseek (fd offset whence) (int-errno-ffcall (%kernel-import target::kernel-import-lisp-lseek) :int fd :signed-doubleword offset :int whence :signed-doubleword)) (defun fd-close (fd) (int-errno-ffcall (%kernel-import target::kernel-import-lisp-close) :int fd :int)) (defun fd-tell (fd) (fd-lseek fd 0 #$SEEK_CUR)) ;;; Kernels prior to 2.4 don't seem to have a "stat" variant ;;; that handles 64-bit file offsets. (defun fd-size (fd) (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat)) (if (eql 0 (ff-call (%kernel-import target::kernel-import-lisp-fstat) :int fd :address stat :int)) (pref stat #-windows-target :stat.st_size #+win64-target #>_stat64.st_size #+win32-target #>__stat64.st_size) -1))) (defun fd-ftruncate (fd new) (int-errno-ffcall (%kernel-import target::kernel-import-lisp-ftruncate) :int fd :off_t new :int)) (defun %string-to-stderr (str) (with-cstrs ((s str)) (fd-write 2 s (length str)))) (defun pdbg (string) (%string-to-stderr string) (%string-to-stderr #.(string #\LineFeed))) ;;; Not really I/O, but ... (defun malloc (size) (ff-call (%kernel-import target::kernel-import-malloc) :unsigned-fullword size :address)) (defun free (ptr) (let* ((size (uvsize ptr)) (flags (if (= size target::xmacptr.size) (uvref ptr target::xmacptr.flags-cell) $flags_DisposPtr))) (declare (fixnum size flags)) (if (= flags $flags_DisposPtr) (with-macptrs ((addr ptr)) (when (= size target::xmacptr.size) (%setf-macptr ptr (%null-ptr)) (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal)) (ff-call (%kernel-import target::kernel-import-free) :address addr :void)))))