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

Implemented some more missing kludges for mocl.

parent b3fcef15
......@@ -126,6 +126,10 @@
(defun my-eval (form)
(when *eval-out* (get-output-stream-string *eval-out*))
(when *eval-err* (get-output-stream-string *eval-err*))
#+mocl
(ecase *eval-method*
(:eval (eval form)))
#-mocl
(ecase *eval-method*
(:eval (eval form))
(:compile (funcall (compile nil `(lambda () ,form))))
......
......@@ -41,6 +41,27 @@
(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY"
(: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")
(:export
"POSITIONS" ; should go to a sequence package...
......
......@@ -32,9 +32,29 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>
;;;;****************************************************************************
(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE"
(: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")
(:export "CACHE-EXPIRE-ALL" "CACHE-EXPIRE" "CACHE-EXPIRATION" "CACHE-GET"
"SYNCHRONIZE-CACHE" "MAKE-CACHE" "CACHE-PRODUCER" "CACHE-VALUE-FILE-TYPE"
"CACHE-INDEX-FILE-PATH" "CACHE-DIRECTORY-PATH" "CACHE"
......
......@@ -474,12 +474,14 @@ RETURN: The package named PACKAGE-NAME if found, or NIL.
(unless (registeredp package-name)
(prog1
(or
(common-lisp:load (object-dir path)
(#+mocl COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING:load
#-mocl common-lisp:load (object-dir path)
:verbose verbose
:print print
:if-does-not-exist nil
:external-format external-format)
(common-lisp:load path
(#+mocl COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING:load
#-mocl common-lisp:load path
:verbose verbose
:print print
:if-does-not-exist if-does-not-exist
......
......@@ -392,8 +392,8 @@ but some types are used only for array cells (ie. unboxed values)."
(cvm-find-package ,(cdr type)))))
(cvm-structure-ref self 0))))
,@(loop
:for field :in fields
:for index :from 1
:for field :in fields
:for index :from 1
:append (let ((cst (intern (format nil "+~A-~A+" name field)))
(get (intern (format nil "CVM-~A-~A" name field)))
(set (intern (format nil "CVM-~A-SET-~A" name field))))
......@@ -423,13 +423,13 @@ but some types are used only for array cells (ie. unboxed values)."
;;--------------------------
(cvm-define-structure hh
;; the only instance of this structure is stored in the common heap.
("HEAP-HEADER" . "SYSTEM")
size ; ct-fixnum
free-blocks ; ct-vector of ct-free-block
root ; ct-nil or ct-address to a ct-cons
new-generation ; ct-nil or ct-address to a ct-vector-fp
reserved)
;; the only instance of this structure is stored in the common heap.
("HEAP-HEADER" . "SYSTEM")
size ; ct-fixnum
free-blocks ; ct-vector of ct-free-block
root ; ct-nil or ct-address to a ct-cons
new-generation ; ct-nil or ct-address to a ct-vector-fp
reserved)
;; We need to keep a new-generation list for partially allocated objects
......
......@@ -391,7 +391,7 @@ DO: Displays the contents of the working directory and
(change-working-directory
(child-directory (working-directory) (elt subdirs (1- answer)))))
(t (load (cdr (elt files (- answer (length subdirs) 1)))
:verbose t)))))))
:verbose t)))))))
(defun resolve (path &key (directory nil))
......
......@@ -1320,9 +1320,10 @@ URL: <http://www.lispworks.com/documentation/HyperSpec/Body/f_set_ma.htm>
to enable TRACE and redefinitions of the dispatch macro character function."
(set-dispatch-macro-character
disp-char sub-char
(compile nil
(let ((s (gensym)) (c (gensym)) (a (gensym)))
`(lambda (,s ,c ,a) (,function-name ,s ,c ,a))))
#+mocl (lambda (s c a) (funcall function-name s c a))
#-mocl (compile nil
(let ((s (gensym)) (c (gensym)) (a (gensym)))
`(lambda (,s ,c ,a) (,function-name ,s ,c ,a))))
readtable))
(defun set-indirect-macro-character (char function-name
......@@ -1331,9 +1332,10 @@ to enable TRACE and redefinitions of the dispatch macro character function."
to enable TRACE and redefinitions of the macro character function."
(set-macro-character
char
(compile nil
(let ((s (gensym)) (a (gensym)))
`(lambda (,s ,a) (,function-name ,s ,a))))
#+mocl (lambda (s c) (funcall function-name s c))
#-mocl (compile nil
(let ((s (gensym)) (a (gensym)))
`(lambda (,s ,a) (,function-name ,s ,a))))
readtable))
......
......@@ -42,9 +42,30 @@
(declaim (also-use-packages "COM.INFORMATIMAGO.COMMON-LISP.HTML-PARSER.PARSE-HTML"))
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.OBSOLETE-OR-INCOMPLEPTE.WEB-CACHE"
(:use "COM.INFORMATIMAGO.PA.PROCESS-HTML"
"COM.INFORMATIMAGO.PA.HTTP-CLIENT"
"COMMON-LISP")
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.PA.PROCESS-HTML"
"COM.INFORMATIMAGO.PA.HTTP-CLIENT")
#+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 "*CACHE-DIRECTORY-PATH*" "SYNCHRONIZE-CACHE" "FORGET-ALL"
"FORGET-URI" "FREE-PARSED-HTML-AT-URI" "FREE-RESOURCE-AT-URI"
"GET-PARSED-HTML-AT-URI" "GET-RESOURCE-AT-URI")
......
......@@ -1560,7 +1560,7 @@ regexp matched, ie. rnode."
(equalf (function equal)) ;; use equalp for case insensitive.
;; equalf must take two sequence arguments
;; and accept :start1 :end1 :start2 :end2 keys.
(newlinepf (compile nil (lambda (ch) (eql #\NEWLINE ch))))
(newlinepf (lambda (ch) (eql #\NEWLINE ch)))
(sequence "" :type vector) ;; renv-set-sequence sets length and position too.
(length 0 :type (integer 0))
(position 0 :type (integer 0))
......
......@@ -102,6 +102,10 @@ LEGAL
"))
(in-package "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING")
;; CHANGE-CLASS ;; CLOS!
;; COMPLEX ;; all complex is missing.
(defvar *load-verbose* nil)
(defvar *load-print* nil)
(defvar *trace-output* *standard-output*)
......@@ -113,12 +117,17 @@ LEGAL
(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!
(defun ARRAY-DISPLACEMENT (array)
;; if not provided, then displaced array don't exist!
(declare (ignore array))
(values nil 0))
;; COMPILE ;; required to implement minimal compilation.
;; COMPLEX ;; all complex is missing.
(defun LOAD (filespec &key verbose print if-does-not-exist external-format)
)
(defun ENSURE-DIRECTORIES-EXIST (pathspec &key verbose)
(error "~S not implemented yet" 'ENSURE-DIRECTORIES-EXIST)
......@@ -144,15 +153,22 @@ LEGAL
(rt:formatd "Debugger invoked on condition ~A; aborting." condition)
(rt:quit))
(defun LOAD (filespec &key verbose print if-does-not-exist external-format)
)
(defvar *hosts* '())
(defun LOGICAL-PATHNAME-TRANSLATIONS (host)
)
(cdr (assoc host *hosts* :test (function equalp))))
(defun (setf LOGICAL-PATHNAME-TRANSLATIONS) (new-translations host)
)
(let ((entry (assoc host *hosts* :test (function equalp))))
(if entry
(setf (cdr entry) (copy-tree new-translations))
(push (cons (nstring-upcase (copy-seq host))
(copy-tree new-translations))
*hosts*))))
(defun TRANSLATE-LOGICAL-PATHNAME (pathname &key &allow-other-keys)
)
(error "~S not implemented yet" 'TRANSLATE-LOGICAL-PATHNAME)
pathname)
(defun MACHINE-INSTANCE ()
;; TODO: find the hostname of the machine, or some other machine identification.
......@@ -174,9 +190,74 @@ LEGAL
(declare (ignore key test test-not))
(apply (function set-difference) list-1 list-2 rest))
(defun nsubstitute-if (new-item predicate sequence &key from-end start end count key)
(let* ((length (length sequence))
(start (or start 0))
(end (or end lengh))
(key (or key (function identity))))
(assert (<= 0 start end length))
(etypecase sequence
(list (cond
(from-end
(nreverse (nsubstitute-if new-item predicate (nreverse sequence)
:start (- length end) :end (- length start)
:count count :key key)))
(count
(when (plusp count)
(loop
:repeat (- end start)
:for current :on (nthcdr start sequence)
:do (when (funcall predicate (funcall key (car current)))
(setf (car current) new-item)
(decf count)
(when (zerop count)
(return))))))
(t
(loop
:repeat (- end start)
:for current :on (nthcdr start sequence)
:do (when (funcall predicate (funcall key (car current)))
(setf (car current) new-item))))))
(vector (if from-end
(if count
(when (plusp count)
(loop
:for i :from (1- end) :downto start
:do (when (funcall predicate (funcall key (aref sequence i)))
(setf (aref sequence i) new-item)
(decf count)
(when (zerop count)
(return)))))
(loop
:for i :from (1- end) :downto start
:do (when (funcall predicate (funcall key (aref sequence i)))
(setf (aref sequence i) new-item))))
(if count
(when (plusp count)
(loop
:for i :from start :below end
:do (when (funcall predicate (funcall key (aref sequence i)))
(setf (aref sequence i) new-item)
(decf count)
(when (zerop count)
(return)))))
(loop
:for i :from start :below end
:do (when (funcall predicate (funcall key (aref sequence i)))
(setf (aref sequence i) new-item)))))))
sequence))
(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))
(defun NSUBSTITUTE-IF-NOT (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item (complement predicate) sequence rest))
(defun SUBSTITUTE-IF-NOT (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item (complement predicate) (copy-seq sequence) rest))
;; Warning: Function ASDF:FIND-SYSTEM is referenced but not defined.
......@@ -186,4 +267,3 @@ LEGAL
;;;; THE END ;;;;
......@@ -275,7 +275,8 @@ NOTE: The grammar is not added to the *grammars* map.
(grammar-all-non-terminals grammar))
,(generate-parser target-language grammar))))
(if compile
(funcall (compile nil `(lambda () ,code)))
(funcall #+mocl (coerce `(lambda () ,code) 'function)
#-mocl (compile nil `(lambda () ,code)))
(eval code)))
grammar))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment