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

Added mocl/kludges/missing.lisp, and use it.

parent b5596a6f
......@@ -386,6 +386,7 @@ RETURN: If the file (cache-index-file-path self) exists
"
DO: Load the cache index from the file (cache-index-file-path self).
"
#+debug-COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE
(format *trace-output* "~&Loading cache ~S~%" (cache-index-file-path self))
(with-open-file (file (cache-index-file-path self)
:direction :input :if-does-not-exist :error)
......@@ -433,6 +434,7 @@ DO: Load the cache index from the file (cache-index-file-path self).
"
DO: Save the cache index to the file (cache-index-file-path self).
"
#+debug-COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE
(format *trace-output* "~&Saving cache ~S~%" (cache-index-file-path self))
(ensure-directories-exist (cache-index-file-path self))
(let ((tmp-name (make-pathname :type "NEW"
......@@ -519,12 +521,11 @@ RETURN: the value stored in the CACHE for the KEY;
(cond
((or (null entry) ; no entry ==> fetch
(< (entry-expire-date entry) (get-universal-time)))
#+debug-COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE
(if (null entry)
(format *trace-output*
"~&(cache-get ~S): No cache entry ==> fetch~%" key)
(format *trace-output*
"~&(cache-get ~S): expired (~A<~A) ==> fetch~%"
key (entry-expire-date entry) (get-universal-time)))
(format *trace-output* "~&(cache-get ~S): No cache entry ==> fetch~%" key)
(format *trace-output* "~&(cache-get ~S): expired (~A<~A) ==> fetch~%"
key (entry-expire-date entry) (get-universal-time)))
#+(or)(invoke-debugger (make-condition 'simple-error
:format-control "~&~S not in ~S~%"
:format-arguments (list key (slot-value self 'index) self)))
......@@ -548,6 +549,7 @@ RETURN: the value stored in the CACHE for the KEY;
(synchronize-cache self)
(values value :fetched))))
((entry-value-p entry) ; ==> in core
#+debug-COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE
(format *trace-output* "~&(cache-get ~S): got it in core~%" key)
(values (entry-value entry) :in-core))
(t ; ==> read from disk
......@@ -558,6 +560,7 @@ RETURN: the value stored in the CACHE for the KEY;
(let ((*read-eval* nil)) (read in)))))
(setf (entry-value entry) value
(entry-value-p entry) t)
#+debug-COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE
(format *trace-output* "~&(cache-get ~S): read from disk~%" key)
(values value :on-disk)))))))
......
......@@ -48,6 +48,23 @@
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ASCII"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STREAM")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STREAM"
"CONTENTS-FROM-STREAM"
"STREAM-TO-STRING-LIST" "COPY-STREAM" "COPY-OVER")
......
......@@ -134,8 +134,27 @@ License:
")
(:use "COMMON-LISP")
(:use "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
(:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:export "PACKAGE-EXPORTS" ;; missing from CL or not?
"*PACKAGES*" "PACKAGE-PATHNAME" "LOAD-PACKAGE"
"PACKAGE-SYSTEM-DEFINITION"
......@@ -435,9 +454,6 @@ DO: Force registering the PACKAGE into the loaded *PACKAGES*.
path))
#+mocl (defvar *load-verbose* nil)
#+mocl (defvar *load-print* nil)
(defun load-package (package-name
&key (verbose *load-verbose*) (print *load-print*)
(if-does-not-exist :error)
......
......@@ -40,6 +40,25 @@
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:export "*DEBUG-ON-ERROR*" "WITH-DEBUGGER-ON-ERROR"
"DEFINE-TEST" "TEST" "ASSERT-TRUE" "ASSERT-FALSE" "EXPECT-CONDITION"
......@@ -114,9 +133,6 @@ License:
(values))
#+mocl (defvar *load-verbose* nil)
#+mocl (defvar *load-print* nil)
(defun verbose (default)
(and default
(or (not *load-pathname*)
......
......@@ -53,6 +53,27 @@
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:export
;; 3 - EVALUATION AND COMPILATION
"WITH-GENSYMS" "WSIOSBP" "PROGN-CONCAT"
......@@ -728,8 +749,7 @@ SEE: PRINT-PARSEABLE-OBJECT
(let ((*step-mode* :run))
(declare (special *step-mode*))
(if *print-readably*
#+mocl (error "not printable readably ~S"object)
#-mocl (error 'print-not-readable :object object)
(error 'print-not-readable :object object)
(progn
(format stream "~S"
(append (when type
......
......@@ -43,6 +43,30 @@
(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.ED.ED"
(:use "COMMON-LISP")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:shadow "ED")
(:export "ED")
(:documentation
"
This package exports an implementation of the COMMON-LISP ED function
......@@ -78,8 +102,8 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2003 - 2012
Copyright Pascal J. Bourguignon 2003 - 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
......@@ -94,10 +118,7 @@ License:
along with this program.
If not, see <http://www.gnu.org/licenses/>
")
(:use "COMMON-LISP")
(:shadow "ED")
(:export "ED"))
"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.ED.ED")
......
......@@ -92,6 +92,27 @@
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.HEAP.MEMORY"
"COM.INFORMATIMAGO.COMMON-LISP.DATA-ENCODING.IEEE-754")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
;; "COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "WSIOSBP" "DEFENUM")
(:export "SET-COMMON" "GET-COMMON" "WITH-COMMON-LOCK" "*COMMON-VARIABLES*"
"DEFCOMMON" "COMMON-INITIALIZE")
......@@ -164,7 +185,6 @@ License:
")))
(defvar *debug* nil)
#+mocl (defvar *trace-output* *standard-output*)
(defmacro when-debug (what &body body)
(cond
......@@ -2356,6 +2376,7 @@ DO: Initialize the heap in *gc-memory*.
((typep value 'single-float) (cvm-form-single-float value))
(t (error "double-float and long-float unsupported yet."))))
(:method ((value ratio)) (declare (ignorable value)) (error "No ratio yet."))
#-mocl
(:method ((value complex)) (declare (ignorable value)) (error "No complex yet."))
;; 1- allocate the current node and store it to the ld hash before
;; 2- allocating the sub-nodes.
......
This diff is collapsed.
......@@ -44,6 +44,27 @@
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.INTERACTIVE.BROWSER"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:export "MAKE" "MV" "CP" "DEFCOMMAND" "*SHELL*" "LESS" "MORE" "CAT" "LS"
"MKDIR" "POPD" "PUSHD" "PWD" "CD" "BROWSE" "*TERMINAL-HEIGHT*"
"CHANGE-WORKING-DIRECTORY" "WORKING-DIRECTORY" "*CHANGE-DIRECTORY-HOOK*"
......@@ -62,7 +83,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2002 - 2012
Copyright Pascal J. Bourguignon 2002 - 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
......
......@@ -43,6 +43,27 @@
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ISO4217")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:export "LOAD-JOURNAL" "JOURNAL-ENTRY" "LINE" "PERSON" "GENERATE" "TRIMESTRE"
"MAKE-BANK-REFERENCE" "JOURNAL" "MOVEMENT" "INVOICE-SET" "INVOICE"
"INVOICE-LINE" "FISCAL-PERSON" "BANK-REFERENCE" "PJB-OBJECT" "*JOURNAL*"
......
......@@ -47,7 +47,23 @@
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:export
"*STEP-PACKAGE*"
"*STEP-PRINT-READABLY*"
......@@ -90,7 +106,7 @@ COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER.
BUGS: we should probably design it with hooks so that clients may
define the stepping/tracing user interface.
Copyright Pascal J. Bourguignon 2012 - 2012
Copyright Pascal J. Bourguignon 2012 - 2015
This package is provided under the Afero General Public License 3.
See the source file for details.
......@@ -106,7 +122,24 @@ See the source file for details.
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
"COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER.INTERNAL")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:shadow ;; macros
"DEFUN" "DEFGENERIC" "DEFMETHOD" "LAMBDA"
"DEFINE-CONDITION"
......@@ -232,7 +265,7 @@ use the (declare (stepper trace)) declaration.
Copyright Pascal J. Bourguignon 2012 - 2012
Copyright Pascal J. Bourguignon 2012 - 2015
This package is provided under the Afero General Public License 3.
See the source file for details.
......
......@@ -1446,7 +1446,7 @@ DO: complements the set.
(defstruct (rnode
(:print-function print-rnode))
(:print-function print-rnode))
"A rnode represent a compiled regexp node"
;; code:
(matchf nil)
......
......@@ -470,7 +470,7 @@ BINDING: must be either a symbol (naming a command),
def-map))
(defparameter *keymap* (keymap-copy *default-keymap*))
(defvar *keymap* nil)
#-clisp
......@@ -1857,36 +1857,40 @@ These commands include C-@ and M-x start-kbd-macro."
:unless (zerop (logand bit bits)) :collect modifier))
(let ((keymap *keymap*)
(sequence '()))
(defun editor-reset-key ()
(setf keymap *keymap*
sequence '()))
(defun editor-process-key (key)
(let ((binding (keymap-binding keymap key)))
(push key sequence)
(cond
((keymapp binding)
(format *log* "editor-process-key -> keymap ~{~A ~}~%" (reverse sequence))
(setf keymap binding))
((or (and (symbolp binding)
(fboundp binding)
(interactivep binding))
(and (functionp binding)
(interactivep binding)))
(format *log* "editor-process-key -> binding ~{~A ~} --> ~S~%" (reverse sequence) binding)
(setf *last-command-char* (first sequence)
*this-command* binding
*current-prefix-arg* *prefix-arg*
*prefix-arg* nil)
(call-interactively binding)
(setf *last-command* *this-command*)
(editor-reset-key))
((null binding)
(beep))
(t (message "~{~A ~} is bound to a non-command: ~S~%"
(reverse sequence) binding)
(editor-reset-key))))))
(defvar *current-keymap* nil)
(defvar *current-sequence* '())
(defun editor-reset-key ()
(setf *current-keymap* *keymap*
*current-sequence* '()))
(defun editor-process-key (key)
(let ((binding (keymap-binding *current-keymap* key)))
(push key *current-sequence*)
(cond
((keymapp binding)
(format *log* "editor-process-key -> keymap ~{~A ~}~%"
(reverse *current-sequence*))
(setf *current-keymap* binding))
((or (and (symbolp binding)
(fboundp binding)
(interactivep binding))
(and (functionp binding)
(interactivep binding)))
(format *log* "editor-process-key -> binding ~{~A ~} --> ~S~%"
(reverse *current-sequence*) binding)
(setf *last-command-char* (first *current-sequence*)
*this-command* binding
*current-prefix-arg* *prefix-arg*
*prefix-arg* nil)
(call-interactively binding)
(setf *last-command* *this-command*)
(editor-reset-key))
((null binding)
(beep))
(t (message "~{~A ~} is bound to a non-command: ~S~%"
(reverse *current-sequence*) binding)
(editor-reset-key)))))
......
......@@ -54,7 +54,7 @@
(inter (find 'interactive decls :key (function first))))
(if inter
`(progn
(compile (cl:defun ,name ,arguments ,@body))
(cl:defun ,name ,arguments ,@body)
(setf (gethash ',name *interactive-decls*) ',inter
(gethash (function ,name) *interactive-decls*) ',inter)
',name)
......@@ -70,10 +70,9 @@
(let* ((decls (mapcan (function rest) (extract-declarations body)))
(inter (find 'interactive decls :key (function first))))
(if inter
`(progn
(let ((fun (compile nil '(cl:lambda ,arguments ,@body))))
(setf (gethash fun *interactive-decls*) ',inter)
fun))
`(flet ((anonymous-function ,arguments ,@body))
(setf (gethash (function anonymous-function) *interactive-decls*) ',inter)
(function anonymous-function))
`(cl:lambda ,arguments ,@body))))
......
......@@ -39,6 +39,23 @@
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.DLL"
"COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING")
#+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
"*TRACE-OUTPUT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME")
(:shadow "DEFUN" "LAMBDA" "ED" "ERROR")
(:export "DEFUN" "LAMBDA" "ED")
(:export "SCREEN-EDITOR" "EDITOR")
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: missing.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Implements CL standard operators missing from MoCL.
;;;;
;;;; !!!! NOTICE THE LICENSE OF THIS FILE !!!!
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-03-01 <PJB> Created.
;;;;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/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
(:use "COMMON-LISP")
(:shadow "*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:export "*TRACE-OUTPUT*"
"*LOAD-VERBOSE*"
"*LOAD-PRINT*"
"ARRAY-DISPLACEMENT"
"CHANGE-CLASS"
"COMPILE"
"COMPLEX"
"ENSURE-DIRECTORIES-EXIST"
"FILE-WRITE-DATE"
"INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
"LOAD"
"LOGICAL-PATHNAME-TRANSLATIONS"
"MACHINE-INSTANCE"
"MACHINE-VERSION"
"NSET-DIFFERENCE"
"RENAME-FILE"
"SUBSTITUTE-IF"
"TRANSLATE-LOGICAL-PATHNAME"
"PRINT-NOT-READABLE"
"PRINT-NOT-READABLE-OBJECT")
(:documentation "
Implements CL standard operators missing from MoCL.
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.MOCL.KLUDGES.MISSING")
(defvar *load-verbose* nil)
(defvar *load-print* nil)
(defvar *trace-output* *standard-output*)
(define-condition print-not-readable (error)
((object :initarg :object :reader print-not-readable-object))
(:report (lambda (condition stream)
(let ((*print-readably* nil))
(format stream "Object to printable readably ~S"
(print-not-readable-object condition))))))
;; ARRAY-DISPLACEMENT ;; we cannot really do anything bar re-implementing arrays.
;; CHANGE-CLASS ;; CLOS!
;; COMPILE ;; required to implement minimal compilation.
;; COMPLEX ;; all complex is missing.
(defun ENSURE-DIRECTORIES-EXIST (pathspec &key verbose)
(error "~S not implemented yet" 'ENSURE-DIRECTORIES-EXIST)
(let ((created nil))
(values pathspec created)))
(defun RENAME-FILE (filespec new-name)
(error "~S not implemented yet" 'RENAME-FILE)
(let (defaulted-new-name old-truename new-truename)
(values defaulted-new-name old-truename new-truename)))
(defun FILE-WRITE-DATE (pathspec)
(declare (ignore pathspec))
nil)
(defvar *debugger-hook* nil)
(defun INVOKE-DEBUGGER (condition)
(when *debugger-hook*
(let ((saved-hook *debugger-hook*)
(*debugger-hook* nil))
(funcall saved-hook condition)))
(rt:formatd "Debugger invoked on condition ~A; aborting." condition)
(rt:quit))
(defun LOAD (filespec &key verbose print if-does-not-exist external-format)
)
(defun LOGICAL-PATHNAME-TRANSLATIONS (host)
)
(defun (setf LOGICAL-PATHNAME-TRANSLATIONS) (new-translations host)
)
(defun TRANSLATE-LOGICAL-PATHNAME (pathname &key &allow-other-keys)
)
(defun MACHINE-INSTANCE ()
;; TODO: find the hostname of the machine, or some other machine identification.
#+android "Android"
#+ios "iOS")
(defun MACHINE-VERSION ()
;; TODO: find the hardware version, or some other machine version.
#+android "0.0"
#+ios "0.0")
;; Clozure Common Lisp --> ("larissa.local" "MacBookAir6,2")
;; CLISP --> ("larissa.local [192.168.7.8]" "X86_64")
;; ECL --> ("larissa.local" NIL)
;; SBCL --> ("larissa.local" "Intel(R) Core(TM) i7-4650U CPU @ 1.70GHz")
(defun NSET-DIFFERENCE (list-1 list-2 &rest rest &key key test test-not)
(declare (ignore key test test-not))
(apply (function set-difference) list-1 list-2 rest))
(defun SUBSTITUTE-IF (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item predicate (copy-seq sequence) rest))
;; Warning: Function ASDF:FIND-SYSTEM is referenced but not defined.
;; Warning: Function ASDF:GETENV is referenced but not defined.