Commit d0b464ae authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Merge branch 'master' of github.com:informatimago/lisp

parents f5a5fa71 88cf8abe
......@@ -1693,8 +1693,8 @@ NOTE: UNIVERSAL-TIME when present gives a base date with
#||
(loop
:repeat 365
:with day = (gregorian :year 2007 :month 1 :day 1 :hour 12)
:repeat 365
:do (princ day) (terpri) (increment-day day))
(com.informatimago.common-lisp.cesarum.date.utility:as-list-of-numbers
......
......@@ -326,10 +326,12 @@ RETURN: A whole line read from the peek-stream, or NIL in case of end of stream
(with-input-from-string (in "ComMon-Lisp")
(let* ((ps (make-instance 'peek-stream :stream in))
(nc (loop
:repeat n :for ch = (get-future-char ps)
:for ch = (get-future-char ps)
:repeat n
:collect ch :into result :finally (return result)))
(gc (loop
:repeat n :for ch = (getchar ps)
:for ch = (getchar ps)
:repeat n
:collect ch :into result :finally (return result))))
(assert (equal nc gc)))))
:success)
......
......@@ -87,7 +87,7 @@ License:
(,sum ,init-sum) (,delta #x9e3779b9)
(,a (aref ,k 0)) (,b (aref ,k 1))
(,c (aref ,k 2)) (,d (aref ,k 3)))
(loop repeat +n+ do ,@body finally (setf (aref ,w 0) ,y (aref ,w 1) ,z))))
(loop :repeat +n+ :do (progn ,@body) :finally (setf (aref ,w 0) ,y (aref ,w 1) ,z))))
(defmacro c-incf (var expr) `(setf ,var (mod (+ ,var ,expr) #x100000000)))
(defmacro c-decf (var expr) `(setf ,var (mod (- ,var ,expr) #x100000000)))
(defun tea-encipher (v w k)
......
......@@ -824,26 +824,26 @@ but some types are used only for array cells (ie. unboxed values)."
(defun test-ieee-read-double ()
(with-open-file (in "value.ieee-754-double"
:direction :input :element-type '(unsigned-byte 8))
(loop while (< (file-position in) (file-length in))
do (loop repeat 8 for i = 1 then (* i 256)
for v = (read-byte in) then (+ v (* i (read-byte in)))
finally (progn
(let ((*print-base* 16)) (princ v))
(princ " ")
(princ (ieee-754-to-float-64 v))
(terpri))))))
(loop :while (< (file-position in) (file-length in))
:do (loop :for i = 1 :then (* i 256)
:for v = (read-byte in) :then (+ v (* i (read-byte in)))
:repeat 8
:finally (let ((*print-base* 16)) (princ v))
(princ " ")
(princ (ieee-754-to-float-64 v))
(terpri)))))
(defun test-ieee-read-single ()
(with-open-file (in "value.ieee-754-single"
:direction :input :element-type '(unsigned-byte 8))
(loop while (< (file-position in) (file-length in))
do (loop repeat 4 for i = 1 then (* i 256)
for v = (read-byte in) then (+ v (* i (read-byte in)))
finally (progn
(let ((*print-base* 16)) (princ v))
(princ " ")
(princ (ieee-754-to-float-32 v))
(terpri))))))
(loop :while (< (file-position in) (file-length in))
:do (loop :for i = 1 :then (* i 256)
:for v = (read-byte in) :then (+ v (* i (read-byte in)))
:repeat 4
:finally (let ((*print-base* 16)) (princ v))
(princ " ")
(princ (ieee-754-to-float-32 v))
(terpri)))))
(defun test-single-to-ieee (&rest args)
(dolist (arg args)
......@@ -973,15 +973,15 @@ CL-USER>
(defun cvm-list-elt (list index)
(loop for curr = list then (cvm-cdr curr)
repeat index
finally (return (cvm-car curr))))
(loop :for curr = list :then (cvm-cdr curr)
:repeat index
:finally (return (cvm-car curr))))
(defun cvm-member-eq (item list)
(loop for curr = list then (cvm-cdr curr)
until (or (cvm-null curr) (eql (cvm-car curr) item))
finally (return curr)))
(loop :for curr = list :then (cvm-cdr curr)
:until (or (cvm-null curr) (eql (cvm-car curr) item))
:finally (return curr)))
(defun cvm-list-nreverse (list)
......@@ -1014,26 +1014,24 @@ CL-USER>
(cond
((zerop length) +cvm-nil+)
(initial-contents
(loop with head = (cvm-make-cons (car initial-contents) +cvm-nil+)
with tail = head
with new = nil
for item in (cdr initial-contents)
repeat length
do (progn
(setf new (cvm-make-cons item +cvm-nil+))
(cvm-setcdr tail new)
(setf tail new))
finally (return head)))
(loop :with head = (cvm-make-cons (car initial-contents) +cvm-nil+)
:with tail = head
:with new = nil
:for item in (cdr initial-contents)
:repeat length
:do (setf new (cvm-make-cons item +cvm-nil+))
(cvm-setcdr tail new)
(setf tail new)
:finally (return head)))
(t
(loop with head = (cvm-make-cons initial-element +cvm-nil+)
with tail = head
with new = nil
repeat length
do (progn
(setf new (cvm-make-cons initial-element +cvm-nil+))
(cvm-setcdr tail new)
(setf tail new))
finally (return head)))))
(loop :with head = (cvm-make-cons initial-element +cvm-nil+)
:with tail = head
:with new = nil
:repeat length
:do (setf new (cvm-make-cons initial-element +cvm-nil+))
(cvm-setcdr tail new)
(setf tail new)
:finally (return head)))))
;; TODO: implement cvm-push and cvm-pop properly!
......@@ -1186,11 +1184,11 @@ CL-USER>
(values (cvm-fixnum-value (gc-load (incf address)))
(incf address 2)))
((#.ct-array)
(values (loop repeat (cvm-fixnum-value (gc-load (incf address)))
for row-dimension = 1
then (* row-dimension
(cvm-fixnum-value (gc-load (incf address))))
finally (return row-dimension))
(values (loop :for row-dimension = 1
:then (* row-dimension
(cvm-fixnum-value (gc-load (incf address))))
:repeat (cvm-fixnum-value (gc-load (incf address)))
:finally (return row-dimension))
(incf address)))
(otherwise (error "CVM-ROWS: bad argument type ~A (~D)"
(cell-type-label (cvm-type-code (gc-load address)))
......@@ -1577,10 +1575,10 @@ RETURN: When OPERATION is :peek, the value of the slot.
(dump (1+ address) (gc-load (1+ address)) "[el|dm]")
(if (= ct-t (cvm-type-of (gc-load (1+ address))))
(when contents
(loop for address from (+ 2 address)
repeat (- (cvm-size-of object) 2) do
(format stream "~A" margin)
(gc-dump-cell address :stream stream :margin margin)))
(loop :for address from (+ 2 address)
:repeat (- (cvm-size-of object) 2)
:do (format stream "~A" margin)
(gc-dump-cell address :stream stream :margin margin)))
(gc-dump-block (+ 2 address) (- (cvm-size-of object) 2)
stream :margin margin)))
(otherwise
......@@ -1642,20 +1640,20 @@ RETURN: When OPERATION is :peek, the value of the slot.
(setf (aref bitmap address) 2))
(defun gc-bitmap-set-allocated-range (bitmap address size)
(loop repeat size
for i from address do
(assert (evenp (aref bitmap i))) ; 0 or 2
(setf (aref bitmap i) 2)))
(loop :for i :from address
:repeat size
:do (assert (evenp (aref bitmap i))) ; 0 or 2
(setf (aref bitmap i) 2)))
(defun gc-bitmap-set-visited (bitmap address)
(assert (= 2 (aref bitmap address)))
(setf (aref bitmap address) 3))
(defun gc-bitmap-set-visited-range (bitmap address size)
(loop repeat size
for i from address do
(assert (= 2 (aref bitmap i)))
(setf (aref bitmap i) 3)))
(loop :for i :from address
:repeat size
:do (assert (= 2 (aref bitmap i)))
(setf (aref bitmap i) 3)))
(defun gc-bitmap-clear-p (bitmap address) (= 0 (aref bitmap address)))
(defun gc-bitmap-free-p (bitmap address) (= 1 (aref bitmap address)))
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: charm-screen.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Implements a SCREEN using CL-CHARMS.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <[email protected]>
;;;;MODIFICATIONS
;;;; 2015-01-11 <PJB> Extracted from editor.lisp
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "COM.INFORMATIMAGO.EDITOR")
(defclass charms-screen (screen)
()
(:documentation "This SCREEN subclass uses cl-charms (ncurses)."))
(defmethod screen-size ((screen charms-screen))
(multiple-value-bind (width height)
(charms:window-dimensions charms:*standard-window*)
(values height (1- width))))
(defmethod screen-cursor-position ((screen charms-screen))
(charms:cursor-position charms:*standard-window*))
(defmethod set-screen-cursor-position ((screen charms-screen) line column)
(charms:move-cursor charms:*standard-window* column line))
(defmethod clear-screen-to-eot ((screen charms-screen))
(charms:clear-window-after-cursor charms:*standard-window*))
(defmethod clear-screen-to-eol ((screen charms-screen))
(charms:clear-line-after-cursor charms:*standard-window*))
(defmethod delete-screen-line ((screen charms-screen))
;; (charms/ll:deleteln)
)
(defmethod insert-screen-line ((screen charms-screen))
;; (charms/ll:insertln)
)
(defmethod screen-highlight-on ((screen charms-screen))
)
(defmethod screen-highlight-off ((screen charms-screen))
)
(defmethod screen-cursor-on ((screen charms-screen))
)
(defmethod screen-cursor-off ((screen charms-screen))
)
(defmethod screen-write-string ((screen charms-screen) string)
(loop :for ch :across string
:do (charms:write-char-at-cursor charms:*standard-window* ch))
;; (charms:write-string-at-cursor charms:*standard-window* string)
string)
(defmethod screen-refresh ((screen charms-screen))
(charms:refresh-window charms:*standard-window*))
(defmethod keyboard-chord-no-hang ((screen charms-screen))
(let ((ch (charms:get-char charms:*standard-window* :ignore-error t)))
(when ch
(if (find ch #(#\newline #\tab #\esc #\return #\rubout))
(make-instance 'chord :character ch :modifiers 0)
(let* ((code (char-code ch))
(kode (mod code 128))
(controlp (< kode 32))
(metap (< 128 code)))
(make-instance 'chord
:character (code-char (+ kode
(if controlp
(if (< 0 kode 27)
(load-time-value (char-code #\`))
(load-time-value (char-code #\@)))
0)))
:modifiers (+ (if controlp
(expt 2 +control+)
0)
(if metap
(expt 2 +meta+)
0))))))))
(defmethod call-with-screen ((screen charms-screen) thunk)
(charms:with-curses ()
(charms:disable-echoing)
(charms:enable-raw-input :interpret-control-characters nil)
(charms:enable-non-blocking-mode charms:*standard-window*)
(charms:enable-extra-keys charms:*standard-window*) ; keypad t
(charms::check-status (charms/ll:meta (charms::window-pointer charms:*standard-window*) charms/ll:TRUE))
(funcall thunk screen)))
;; (defmethod call-with-current-screen ((screen charms-screen) thunk)
;; )
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: clisp-screen.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Implements a SCREEN using clisp screen package.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <[email protected]>
;;;;MODIFICATIONS
;;;; 2015-01-11 <PJB> Extracted from editor.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "COM.INFORMATIMAGO.EDITOR")
(defclass clisp-screen (screen)
((stream :reader screen-stream :initform (screen:make-window)))
(:documentation "This SCREEN subclass uses the CLISP SCREEN package."))
(defmethod screen-open ((screen clisp-screen))
(setf (screen-stream screen) (screen:make-window)))
(defmethod screen-close ((screen clisp-screen))
(close (screen-stream screen)))
(defmethod screen-initialize-for-terminal ((screen clisp-screen) terminal)
(cond
((string= "xterm" terminal)
(setf custom:*terminal-encoding* (ext:make-encoding
:charset charset:iso-8859-1
:line-terminator :unix)))
((string= "kterm" terminal)
(setf custom:*terminal-encoding* (ext:make-encoding
:charset charset:utf-8
:line-terminator :unix)))
(t
(warn "Unexpected terminal ~S" terminal))))
(defmethod screen-size ((screen clisp-screen))
(screen:window-size (screen-stream screen)))
(defmethod screen-cursor-position ((screen clisp-screen))
(screen:window-cursor-position (screen-stream screen)))
(defmethod set-screen-cursor-position ((screen clisp-screen) line column)
(screen:set-window-cursor-position (screen-stream screen) line column))
(defmethod clear-screen ((screen clisp-screen))
(screen:clear-window (screen-stream screen)))
(defmethod clear-screen-to-eot ((screen clisp-screen))
(screen:clear-window-to-eot (screen-stream screen)))
(defmethod clear-screen-to-eol ((screen clisp-screen))
(screen:clear-window-to-eol (screen-stream screen)))
(defmethod delete-screen-line ((screen clisp-screen))
(screen:delete-window-line (screen-stream screen)))
(defmethod insert-screen-line ((screen clisp-screen))
(screen:insert-window-line (screen-stream screen)))
(defmethod screen-highlight-on ((screen clisp-screen))
(screen:highlight-on (screen-stream screen)))
(defmethod screen-highlight-off ((screen clisp-screen))
(screen:highlight-off (screen-stream screen)))
(defmethod screen-cursor-on ((screen clisp-screen))
(screen:window-cursor-on (screen-stream screen)))
(defmethod screen-cursor-off ((screen clisp-screen))
(screen:window-cursor-off (screen-stream screen)))
(defmethod screen-write-string ((screen clisp-screen) string)
(write-string string (screen-stream screen))
(finish-output (screen-stream screen))
string)
(defmethod screen-refresh ((screen clisp-screen))
screen)
(defmethod keyboard-chord-no-hang ((screen clisp-screen))
(declare (ignorable screen))
(let ((ki (ext:with-keyboard (read-char-no-hang ext:*keyboard-input*))))
(when ki
(make-instance
'chord
:modifiers (loop
:with bits = (ext:char-bits ki)
:for (bit modifier)
:in (load-time-value
(list (list EXT:CHAR-CONTROL-BIT +control+)
(list EXT:CHAR-META-BIT +meta+)
(list EXT:CHAR-SUPER-BIT +super+)
(list EXT:CHAR-HYPER-BIT +hyper+)))
:when (logand bits bit)
:sum (expt 2 modifier))
:character (let ((ch (or (ext:char-key ki) (character ki))))
(if (ext:char-bit ki :control)
(char-downcase ch)
ch))))))
(defmethod call-with-screen ((screen clisp-screen) thunk)
(unwind-protect (screen:with-window
(setf (screen-stream screen) screen:*window*)
(funcall thunk screen))
(setf (screen-stream screen) nil)))
;; (defmethod call-with-current-screen ((screen clisp-screen) thunk)
;; (assert (and screen:*window* (eql screen:*window* (screen-stream screen))))
;; (funcall thunk screen))
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: clisp.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; clisp specific functions.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <[email protected]>
;;;;MODIFICATIONS
;;;; 2015-01-11 <PJB> Extracted from editor.lisp
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "COM.INFORMATIMAGO.EDITOR")
(defun make-xterm-io-stream (&key display geometry)
(let* ((pipe (with-open-stream (s (ext:make-pipe-input-stream
"mktemp /tmp/clisp-x-io-XXXXXX"))
(read-line s)))
(title "CLISP I/O")
;; (clos::*warn-if-gf-already-called* nil)
(font nil
#+(or) "-*-console-medium-r-normal-*-16-*-*-*-*-*-*-*"
#+(or)"-dec-terminal-bold-r-normal-*-14-*-*-*-*-*-dec-dectech"))
;; xterm creates a pty, forks, hooks the pty to stdin/stdout
;; and exec bash with the commands given in -e.
;; We write this pty path to our pipe,
;; and cat our pipe to wait for the end.
;; Meanwhile, we'll be reading and writing this pty.
(ext:shell (format nil "rm -f ~S; mknod ~S p; xterm ~
~:[~;~:*-geometry ~S~] ~:[~;~:*-display ~S~] ~
-fg green -bg black ~:[~;~:*-fn '~A'~] -n ~S -T ~S ~
-e 'tty >> ~S ; cat ~S' &"
pipe pipe geometry display font title title pipe pipe))
(let* ((tty-name (with-open-file (s pipe) (read-line s)))
(xio (make-two-way-stream
(open tty-name :direction :input :buffered nil)
(open tty-name :direction :output :buffered nil))))
(system::terminal-raw (two-way-stream-input-stream xio) t t)
(defmethod close :after ((x (eql xio)) &rest junk)
(declare (ignore x junk))
(ignore-errors
(with-open-file (s pipe :direction :output)
(write-line "Bye." s)))
(delete-file pipe)
(close (two-way-stream-input-stream xio))
(close (two-way-stream-output-stream xio))
(let () ;; ((clos::*warn-if-gf-already-called* nil))
(remove-method #'close (find-method #'close '(:after) `((eql ,xio))))))
xio)))
(defun screen-editor (&key log)
(cond
((string= "xterm" (uiop/os:getenv "TERM"))
(setf custom:*terminal-encoding* (ext:make-encoding
:charset charset:iso-8859-1
:line-terminator :unix)))
((string= "kterm" (uiop/os:getenv "TERM"))
(setf custom:*terminal-encoding* (ext:make-encoding
:charset charset:utf-8
:line-terminator :unix))))
(editor-reset)
(let ((*log* (typecase log
((member :xterm) (make-xterm-io-stream :geometry "100x24+0+0"))
((or string pathname) (open log
:direction :output
:if-exists :append
:if-does-not-exist :create))
(file log)
(otherwise (make-broadcast-stream)))))
(unwind-protect
(with-open-screen (make-instance 'clisp-screen)
(editor-initialize *current-screen*)
(unwind-protect
(keyboard-loop)
(set-screen-cursor-position *current-screen*
0 (screen-size *current-screen*))
(clear-screen *current-screen*))
(editor-terminate))
(close *log*))))
(defun keyboard-test ()
(screen:with-window nil
(screen:set-window-cursor-position screen:*window* 2 10)
(format t "Hi")
(EXT:WITH-KEYBOARD
(LOOP
:for ki = (READ-CHAR EXT:*KEYBOARD-INPUT*)
:do
(print ki)
(print `((ext:char-key ki) ,(ext:char-key ki)))
(print `((character ki)
,(and (not (ext:char-key ki))
(zerop (ext:char-bits ki))
(character ki))))
(print `((ext:char-font ki) ,(ext:char-font ki)))
(print `((ext:char-bits ki) ,(ext:char-bits ki)))
(dolist (modifier '(:control :meta :super :hyper))
(print `((ext:char-bit ki ,modifier) ,(ext:char-bit ki modifier))))
(finish-output)
:until (EQL (and (not (ext:char-key ki))
(zerop (ext:char-bits ki))
(character ki)) #\q)))))
(defun xexample (&key (display ":0.0"))
(let* ((old-terminal-io *terminal-io*)
(xterm-io (make-xterm-io-stream :display display :geometry "+0+0"))
(*terminal-io* xterm-io)
(*standard-output* (make-synonym-stream '*terminal-io*))
(*standard-input* (make-synonym-stream '*terminal-io*))
(*error-output* (make-synonym-stream '*terminal-io*))
(*query-io* (make-synonym-stream '*terminal-io*))
;; (*debug-io* (make-synonym-stream '*terminal-io*))
;; (*trace-output* (make-synonym-stream '*terminal-io*))
(old-term (uiop/os:getenv "TERM")))
(setf (uiop/os:getenv "TERM") "xterm")
(unwind-protect
(progn (format *query-io* "~&Hello!~%")
(format *query-io* "~&X = ")
(finish-output *query-io*)
(let ((x (read *query-io*)))
(format *query-io* "~&~S = ~A~%" '(- (* 2 x) 3) (- (* 2 x) 3)))
(y-or-n-p "Happy?"))
(setf *terminal-io* old-terminal-io)
(close xterm-io)
(setf (uiop/os:getenv "TERM") old-term))))
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: editor.asd
;;;;FILE: com.informatimago.editor.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
......@@ -17,7 +17,7 @@
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2014
;;;; Copyright Pascal J. Bourguignon 2013 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
......@@ -33,19 +33,30 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************