;;-*- Mode: LISP; Package: CYC; Syntax: ANSI-Common-Lisp -*-
;;
;;Douglas R. Miles
;;
;;Saved into a file called common.lisp
;;05/08/2006
#|
SubL is a programming language intended to be very similar to a simplified version of Common Lisp where those features that are either
complex, rarely-used, or difficult to implement in a prodecural language have been removed. Lets put some back.
Sometimes it is hard to port your Common Lisp applications to SubL.
Until you do, you will not be able to transform-block-it with Cyc's internal transform-blockr.
During the interim, here are some usefull functions and macros.
Please help out by [http:://www.cycfoundation.org/foundation/index.php?title=Common_Lisp_Compatibility&action=edit editing] this page.
The goal will be here to implement as much of the Common Lisp language as possible based on the
[http:://www.lisp.org/HyperSpec/FrontMatter/Chapter-Index.html HyperSpec]
*[[Programming]] is based largly on [http:://www.cyc.com/cycdoc/ref/subl-reference.html SubL Reference]
|#
;;
;;(load "CL::package.lisp")
;; A works-arround a current bug in unintern that happens when a uninternal a symbol that came from a C function since its symbol-package is NIL
;; however the bug is only the error it still does its job correctly
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Intitally setup packages
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFVAR *LOADER-PACKAGE* *PACKAGE*)
(EXPORT '*LOADER-PACKAGE* :CYC)
(IN-PACKAGE "CYC")
(DEFINE FORCE-PRINT (&rest BODY) (pwhen (equal 1 (length BODY)) (csetq BODY (first BODY)))(fresh-line) (clet ((res (princ BODY)))(fresh-line)(FORCE-output)(ret res)))
(define FORCE-format (strm &rest BODY)(clet ((res (apply #'format (cons strm BODY))))(pif (streamp strm) (output-stream-p strm) (FORCE-output))(ret res)))
(define FORCE-princ (&rest BODY)(clet ((res (princ BODY)))(FORCE-output)(ret res)))
(EXPORT 'FORCE-PRINT :CYC)
(FORCE-PRINT ";; LOADING COMMON.LISP!")
;; would it payoff to have a #\& reader macro char that goes into LISP: ?
;; do any/many lisps have each package have it own private symbol for '*PACKAGE* ? should dynamically binding it be equivalent to (in-package ...) ?
(defconstant lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &BODY &environment))
(EXPORT 'lambda-list-keywords *PACKAGE*)
(DEFVAR KEYWORD-PACKAGE (find-package :KEYWORD))
(DEFVAR *sticky-symbols* (append '(
*PACKAGE* FORCE-PRINT
*SUBLISP-PACKAGE* KEYWORD-PACKAGE *KEYWORD-PACKAGE*
*CYC-PACKAGE* NIL T) lambda-list-keywords))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFVAR *SUBLISP-DEFMACRO* (find-symbol "DEFMACRO" :SUBLISP))
(DEFVAR *SUBLISP-DEFINE* (find-symbol "DEFINE" :SUBLISP))
(DEFVAR *SUBLISP-LAMBDA* (find-symbol "LAMBDA" :SUBLISP))
(DEFVAR *SUBLISP-FUNCTION* (find-symbol "FUNCTION" :SUBLISP))
(defvar *T-PACKAGE* *package*)
(defvar *T-READTABLE* (COPY-READTABLE *READTABLE*))
;;;;;;;;;;;;;;;;;;------------7--6--5--4--3--2--1
(csetq *symbol-worths* (list '(NIL) '(NIL) '(NIL) '(NIL) '(NIL) '(NIL) '(NIL)))
(define symbol-worth (sym)
(clet ((n (symbol-name sym)))
(pcond
((cor (null sym) (keywordp sym)) (ret 0))
((fboundp sym)
(pwhen (boundp sym) (fif (symbol-value sym)(ret 7) (ret 6)))
(ret 5))
((boundp sym) (fif (symbol-value sym)(ret 4) (ret 3)))
((member-if #'(lambda (a) (ret (search a n))) '("&" "#" "@" "%" "*" "_" ))(ret 2))
(t (ret 1)))))
;; little like shadowing-import with some SubL workarrounds
(define import-symbol (name &optional from (to *PACKAGE*))
(pwhen (consp name)
(ret (cdolist (symbol name) (import-symbol from to))))
(pwhen (symbolp name)
(punless from (csetq from (symbol-origin from)))
(csetq name (symbol-name name)))
(punless (packagep from)
(csetq from (find-package (string from))))
(punless (packagep to)
(csetq to (find-package (string to))))
(clet (found access origin)
(cmultiple-value-bind (found access) (find-symbol name to))
(csetq origin (symbol-package found))
(pwhen (eq origin from)(ret (values found from)))
;;(pwhen (eq origin to)(with-error-handler #'(lambda ()())(unintern name to))
;; (with-error-handler #'(lambda ()())(unINTERN (find-symbol name TO) TO))
(ret (values-list (list (IMPORT (find-symbol NAME FROM) to)(IMPORT (find-symbol NAME FROM) to))))))
(define share-symbols (&optional (from (remove *KEYWORD-PACKAGE* (LIST-ALL-PACKAGES))) (to *PACKAGE*)(count 0))
(punless (consp from) (csetq from (list from)))
(punless (consp to)(csetq from-packages (remove to from)) (csetq to (list to)))
(FORCE-FORMAT t ";; importing from ~s to ~s ~&" from to)
(cdo-all-symbols (s)
(clet ((f (symbol-package s))(n (symbol-name s))(w (symbol-worth s)))
(pwhen (> w 1)
(EXPORT s f)
(cdolist (p from)
(pwhen (> w (symbol-worth (find-symbol n p)))
(cinc count)
(import s p)(import s p))))))
(FORCE-FORMAT t ";; shared ~a symbols" count))
;; cunwind-protect hozed multiple-value-lists so thats the reason for the 'prognvals' weirdness
(defmacro with-package-case (package readcase &rest body) (ret
`(clet ((*READTABLE* *T-READTABLE*)(*PACKAGE* *T-PACKAGE*)
(prognval nil)
(ocase (READTABLE-CASE *READTABLE*))(opack (string (package-name *PACKAGE*))))
(in-package (string (fif (packagep ,package)(package-name ,package) ,package)))
(CSETF (READTABLE-CASE *READTABLE*) ,readcase)
(cunwind-protect (csetf prognvals (multiple-value-list (progn ,@body)))
(CSETF (READTABLE-CASE *READTABLE*) ocase)(in-package opack)(values-list prognvals)))))
;; Read up to the char specified
(define READ-UNTIL (quit-chars &optional (stream *STANDARD-INPUT*)(retstr ""))
(cdo ((lastchar (read-char stream)(read-char stream)))
((member lastchar quit-chars)(unread-char lastchar stream )(ret (values retstr lastchar)))
(csetq retstr (cconcatenate retstr (string lastchar)))))
;; #>CL ::DEFINE interns a non-exported non-inherited into package CL
;; #>CL ::DEFINE interns an exported non-inherited into package CL
;; maybe somehow/day use the SUBLISP::SHARPSIGN-COLON-RMF reader
(define IN-PACKAGE-RMF (stream c n &optional (into-package *KEYWORD-PACKAGE*)(pop-package *PACKAGE*)(exported :INTERNAL))
(clet ( symbol found access symbolname (stream (fif (streamp stream) stream *STANDARD-INPUT*)))
;; (force-print stream c n)
(cunwind-protect
(progn
(in-package (package-name into-package))
(csetq found (read-from-string (read-until '(#\: #\Space) stream "")))
(csetq found (eval found))
(punless (packagep found) (csetq found (find-package (string found))))
(pwhen (packagep found) (csetq into-package found))
;;(punless into-package (cerror "(MAKE-PACKAGE ~s)" "Unknown into-package: ~a" found found `(MAKE-PACKAGE ,found)))
(read-char stream)
(csetq symbolname (read-char stream))
(unread-char symbolname stream)
(punless (equal symbolname #\: )(csetq exported :EXTERNAL))
(IN-PACKAGE (package-name into-package))
(csetq symbolname (read stream nil t nil))
(pcond
;; false alarm
((numberp symbolname)(csetq symbol symbolname))
;; oh well at least we READ from the PACKAGE requested
((consp symbolname)(csetq symbol symbolname))
;; one might use a STRINGP to ensure not to try to intern too early "DEFINE"
((cor (symbolp symbolname)(stringp symbolname))
(cmultiple-value-bind (symbol access) (find-symbol (string symbolname) into-package))
(csetq found (symbol-package symbol))
(pcase access
(NIL
(csetq symbol (make-symbol (string symbolname)))
(csetq symbol (intern symbol into-package)))
(otherwise
(force-format t ";; ~s ~&" `(':symbolname ',symbolname ',exported ':TO ',into-package
':FOUND ',symbol ':IN ',found ':access ',access))
(punless (eq found into-package)
(csetq symbol (make-symbol (string symbolname)))
(import symbol into-package)
(import symbol into-package))))
(pwhen
(equal exported :EXTERNAL)
(export symbol into-package)
(import symbol pop-package)
(import symbol pop-package)))))
;;unwound to
(IN-PACKAGE (package-name pop-package)))
(ret (values symbol T))))
(set-dispatch-macro-character #\# #\> #'IN-PACKAGE-RMF)
(share-symbols)
;; This package is the common lisp implmentation of the cyc LISP it cant inherit from SUBLISP otherwise it will mangle SUBLISP symbols
(DEFVAR *COMMON-LISP-PACKAGE* (make-package "COMMON-LISP" '() '("LISP" "CL" "EXT" "SYSTEM" "IMPL" "SYS" "INT" "INTERNAL")))
(DEFVAR *LISP-PACKAGE* *COMMON-LISP-PACKAGE*)
(DEFVAR *SYSTEM-PACKAGE* *LISP-PACKAGE*)
(DEFVAR *default-package-use* '("CL" "SYS" "EXT" "CYC" "SL")) ;; redundant but ok because it maybe brken up latter
(DEFVAR *COMMON-LISP-USER-PACKAGE* (make-package "COMMON-LISP-USER" *default-package-use* '("USER")))
'(cdolist (sym *sticky-symbols*) (intern sym :CL))
'(cdolist (sym *sticky-symbols*) (import (intern sym :CL) :CL)(export (intern sym :CL) :CL))
;; JUST IN CASE make-symbol starts again working according to SubL Documentation
;;(DEFVAR *LISP-DEFINE* (EXPORT (intern (make-symbol "DEFINE") :SYSTEM) :CL))
;;(DEFVAR *LISP-DEFMACRO* (EXPORT (intern (make-symbol "DEFMACRO") :SYSTEM) :CL))
;;(DEFVAR *LISP-LAMBDA* (EXPORT (intern (make-symbol "LAMBDA") :SYSTEM) :CL))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;TRANSLATION for CL to SUBL - Some of the features of the system must be accessable from everywhere
;;trace-progn - Some of the features of the system must be accessable from everywhere
;;Like the
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(cdo ((i 0 (1+ i))) ((= i (constant-count)))(format t "~a,~a~%" i (constant-name (find-constant-by-internal-id i))))
(define nstring (sym)
(pcond
((null sym) (ret "NIL"))
((stringp sym) (ret sym))
;; ((consp sym) (ret (nstring (car sym))))
((symbolp sym) (ret sym))
((packagep sym) (ret (find-symbol (package-name sym) :KEYWORD)))
(t (ret (write-to-string sym)))))
(defvar *loader-package* *package*)
(defvar *caller-pattern-table* (make-hash-table 23 #'equal) "stores patterns for function destructuring.")
(define lookup-caller-pattern (name)
(ret (gethash name *caller-pattern-table*)))
;;(transform-block bodyin 'form name)))
(defmacro printl (&rest list)
(ret `(print (list ,@list))))
(define mapfuncall (fun list)
(ret (fif (consp list) (cons (funcall fun (car list)) (mapfuncall fun (cdr list))) list)))
(define string-member (item list)
(ret (member item list #'(lambda (item ele) (ret (equal (string (nstring item))(string (nstring ele))))))))
;;(funtest 1 2 3)
;;(defvar *current-eh* *error-handler* "the current/parent error handler")
;;(csetq noblock 'noblock)
(defvar *active-block-names* nil)
(defvar *trace-stack* () "contains information about the last toplevel funcall")
(defvar *trace-tag* :uncalled "contains information about the last toplevel funcall or macroexpansion")
(defvar *trace-notify* () "trace these types")
(defvar *no-trace-fns* '(quote trace-progn t special-form-p make-trace trace-format trace trace-defun error-handler-for lambda nil with-error-handler))
(defvar *trace-next* ())
(defvar *trace-goto* ())
(defvar *trace-code* ())
(defvar *first-error* nil)
(defvar *last-error* nil)
(defvar *error-number* 0)
(defvar *current-code* :none "the current/parent code info")
(defvar *inspected-variables* () "")
(defvar *inspected-functions* () "")
(defvar *error-stack* () "the first error info")
(defvar *current-eh* *error-handler* "the current/parent error handler")
(defconstant lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
(csetq *trace-stack* ())
(csetq *last-error* ())
(csetq *first-error* ())
(csetq *error-stack* ())
(csetq *error-number* 0)
(defmacro trace-warn (&rest code) (ret `(with-error-handler #'(lambda ()(force-format t "~%;;errror: ~a~%;;code: ~a~%" *error-message* ',code)) (progn ,@code))))
(define make-tabs (n) (ret (format nil "(~a):~a" n (make-string (* 3 n)))))
(define named-member (item list);;(trace-format"~s == ~s" item list)
(ret (member item (consify list) #'(lambda (item ele) (ret (equal (coerce-string item)(coerce-string ele)))))))
(define consify (list) (ret(fif (listp list) list (list list))))
(define better-symbol (sujjest current) (ret (> (symbol-worth sujject)(symbol-worth current))))
(define trace-format-type (type string &rest body)
(fif (cor (equal type nil)(equal type 'T)) (ret (apply #'format (cons type (cons string body)))))
(pwhen (equal type :funcall)
(pcond
((null *trace-notify*) (ret nil))
((equal t *trace-notify*)) ;;all funcalls
((member (car (car rest)) *trace-notify*))
(t (ret nil))))
(pwhen (equal type :trace) (punless *trace-notify* (ret nil)))
(fresh-line)
(apply #'format (cons t (cons string body)))
(fresh-line)
(force-format t " ;;~s;;~%" *trace-stack*)
(force-output))
(defmacro trace-format (string &rest rest) (pwhen (stringp string) (ret `(trace-format-type t ,string ,@rest))) (ret `(trace-format-type ,string ,@rest)))
(defvar *trace-fns* '(list ret function))
(define trace-dump (&optional (stack *trace-stack*) (depth 7) (offset 0))
(punless (numberp depth) (csetq depth (fif depth 10000 0)))
(pwhen stack
(cdo ((depth depth (1- depth))(stack stack (cdr stack))(*funcall* (car stack) (car stack)))
((cor (null stack)(> 0 depth))(ret stack))
(format t "; stack:~a ~s~%" (make-string (* 5 (+ offset (length *trace-stack*)))) *funcall*)))
(format t "; stack ~a ~s~%" (make-string (* 5 offset)) :empty))
(define special-form-p (code)
;; (pwhen (macro-operator-p code)(ret code))
(punless (consp code) (ret nil))
(clet ((mac nil)(more nil)(f (car code))(args (cdr code)))
(punless (symbolp f)(ret nil))
(punless (fboundp f)(ret nil))
;;(pwhen (macro-operator-p f) (ret code))
(cmultiple-value-bind (mac more) (macroexpand-1 code))
;;(print (list 2 code mac more))
(punless more (ret nil))
(pwhen (equal mac code) (ret nil))
(pwhen more (ret mac))))
(defmacro sublisp-initvar (var value) (ret `(funless ,var (csetq ,var ,value))))
(define named-member (item list)
;;(trace-format"~s == ~s" item list)
(ret (member item (consify list)
#'(lambda (item ele) (ret (equal (coerce-string item)(coerce-string ele)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Utility functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro init-keyval (key &optional default) (ret `(csetq ,key (fif (key-present-p ',key) (cadr (key-present-p ',key)) ,default))))
(defmacro KeyLet (keys &rest body)
(clet
((varkeys (mapfuncall #'var-of keys))
(initkeys (mapfuncall #'(lambda (key) (fif key (ret `(init-keyval ,(var-of key) ,(init-of key))))) keys)))
(ret (force-print `(clet (,@varkeys) ,@initkeys ,@body)))))
(define var-of (larg) (ret (fif (consp larg) (car larg) larg)))
(define init-of (larg) (ret (fif (consp larg) (cadr larg) nil)))
(defmacro key-present-p (key &optional (keylistname 'lkeys))
(ret `(member-if #'(lambda (x)
(ret (cand (symbolp x)(symbolp ,key)
(equal (symbol-name x) (symbol-name ,key))))) ,keylistname)))
(define var-traceable (vx)
(cond
((symbolp vx)
(ret (pif (char= #\& (char (symbol-name vx) 0)) (list 'quote vx) `(list 'quote ,vx))))
((consp vx) (ret (var-traceable (car vx))))
(t (ret (list 'quote vx)))))
(define trace-each (list) (ret (mapfuncall #'(lambda (xz) (ret `(trace ,xz ))) list)))
(define trace-varinit (var) (ret (fif (consp var) `(,(car var) ,@(mapfuncall #'make-trace (cdr var))) var)))
(defmacro trace (code) (ret (make-trace code)))
(defmacro trace-defun (name args &rest forms) (ret `(trace-tag ,(cons name (mapfuncall #'(lambda (x) (ret (list 'quote x))) args)) ,@forms)))
(defmacro trace-tag (TAG &rest body) (ret `(ret (trace-progn ,@body))))
(defmacro trace-progn (&rest forms) (ret (cons 'progn (mapfuncall #'make-trace forms))))
(define trace-format-type (type string &rest body)
(fif (cor (equal type nil)(equal type 'T)) (ret (apply #'format (cons type (cons string body)))))
(pwhen (equal type :funcall)
(pcond
((null *trace-notify*) (ret nil))
((equal t *trace-notify*)) ;;all funcalls
((member (car (car rest)) *trace-notify*))
(t (ret nil))))
(pwhen (equal type :trace) (punless *trace-notify* (ret nil)))
(fresh-line)
(apply #'format (cons t (cons string body)))
(fresh-line)
(force-format t " ;;~s;;~%" *trace-stack*)
(force-output))
(defmacro trace-format (string &rest rest)
(pwhen (stringp string) (ret `(trace-format-type t ,string ,@rest)))
(ret `(trace-format-type ,string ,@rest)))
(defmacro error-handler-for (code)
(ret `#'(lambda ()
(with-error-handler
#'(lambda () (trace-format "error ~s durring handler~%" *error-message*))
(progn
(funless *first-error* (csetq *first-error* (list *error-message* ',code)))
(csetq *last-error* (list *error-message* ',code))
(cinc *error-number*)
(trace-format "error ~s durring: ~s ~%" *error-message* ',code)
(pwhen (>= *error-number* 0) (ret (break "error-handler-for ~s ~s" *error-message* ',code)))(ret nil))))))
(define make-trace (code)
(punless (consp code)(ret code))
(pwhen (self-evaluating-form-p code)(ret code))
(clet ((f (car code))(args (cdr code))(sp (special-form-p code)))
(pwhen (no-trace-p f)(ret code))
(pwhen (member f *trace-fns*) (ret (cons f (mapfuncall #'make-trace args))))
(pwhen sp (csetq code sp))
(ret
`(progn
(with-error-handler
#'(lambda ()
(trace-format " error ~s durring debug~%" *error-message*)
(printl *trace-tag*)
(trace-format "debugging: ~s => " ',code)
(break))
(with-error-handler
(error-handler-for ',code)
(clet ((result ,code)) (trace-format " ~s~%" result) result)))))))
(define safe-car (list) (ret (fif (consp list)(car list) list)))
(define safe-cdr (list) (ret (fif (consp list)(cdr list) list)))
(defvar *describing* ())
(define no-trace-p (f)
(punless (symbolp f) (ret t))
(fif (search "TRACE" (symbol-name f)) (ret t))
(fif (search "ERROR" (symbol-name f)) (ret t))
(fif (search "FUN" (symbol-name f)) (ret t))
(fif (member f *no-trace-fns*) (ret f)))
(SL::defmacro cl-function (func)
"Introduce a function.
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
(pwhen (string-equal-p (symbol-name (car-safe func)) "FUNCTION") (ret (function (cdar func))))
(pwhen (string-equal-p(symbol-name (car-safe func)) "LAMBDA")
(clet ((res (transform-lambda (cdr func) 'CL::none))
(form (function-lambda-expression (cons *sublisp-lambda* (cdr res)))))
(ret (*SUBLISP-FUNCTION* (fif (car res) (list 'progn (car res) form) form)))))
(pwhen (symbolp func) (ret (symbol-function func)))
(ret (list *SUBLISP-FUNCTION* func)))
;;(defmacro CL::LAMBDA (pattern &rest body)(ret (list 'cl-function (cons *SUBLISP-LAMBDA* (cons pattern `((trace-tag ,pattern ,@body)))))))
;;(unintern 'defun *PACKAGE*)
(defmacro defun (symbol pattern &rest body)
(punless (fboundp (find-symbol (symbol-name symbol)))
;;(FORCE-PRINT `('SYS::DEFINE ,symbol ,pattern ,@body))
(ret (cons *SUBLISP-DEFINE* (cons symbol (cons pattern `((trace-defun ,symbol ,pattern ,@body))))))))
(defmacro CL::DEFINE (symbol pattern &rest body) (ret
`(defun ,symbol ,pattern ,@body)))
(defmacro CL::DEFMACRO (symbol pattern &rest body)
(FORCE-PRINT `('DEFMACRO ,symbol ,pattern ,@body))
(punless (fboundp (find-symbol (symbol-name symbol)))
(ret (cons *SUBLISP-DEFMACRO* (cons symbol (cons pattern `((trace-defun ,symbol ,pattern ,@body))))))))
(defmacro L (pattern &rest body)
(FORCE-PRINT `('SYS::LAMBDA ,pattern ,@body))
(ret (list 'function (cons *SUBLISP-LAMBDA* (cons pattern `((trace-tag ',pattern ,@body)))))))
(break "" )
#|
(import 'CL::LAMBDA :CYC)
(import 'CL::LAMBDA :CYC)
(LAMBDA () 1)
(intern 'lambda *SUBLISP-PACKAGE*)
(unexport 'lambda *CYC-PACKAGE*)
(IMPORT 'DEFVAR :SYS)
(IMPORT 'INTERN :SYS)
(import (find-symbol "DEFMACRO" :SYS) :CYC)
|#
(defun transform-sublvars (patternIn)
(clet ((keyword '&required) (nextkwtype keyword) sublvars keyslist initlist otherkeys wholename)
(cdo ((pattern patternIn (cdr pattern))(op (car patternIn)(car pattern))) ((null pattern))
;; (trace-format"IN: op = ~s ; sublvars ~s; kw = ~s; pattern = ~s ~% ~s " op sublvars keyword pattern (last BodyTop))
(fif (member op lambda-list-keywords)
(pcase op
(&allow-other-keywords (csetq otherkeys op))
(&key
(csetq nextkwtype keyword)
(csetq keyword op)
(csetq sublvars (append sublvars (list '&rest 'lkeys))))
((&rest &body &optional)
(csetq nextkwtype keyword)
(csetq keyword op)
(csetq sublvars (append sublvars (list op))))
((&aux &whole &environment)
(csetq nextkwtype keyword)
(csetq keyword op))
(otherwise))
(pcase keyword
(&aux (csetq initlist (append initlist (list op))))
(&optional (csetq sublvars (append sublvars (list op))))
(&whole
(csetq wholename op)
(csetq initlist (append initlist (list (list wholename `(get-whole)))))
(csetq keyword nextkwtype))
(&environment
(punless (consp op)(setq op `(,op (get-environment))))
(csetq initlist (append initlist (list op)))
(csetq keyword nextkwtype))
((&rest &body)
(csetq sublvars (append sublvars (list op)))
(csetq keyword nextkwtype))
(&key
(csetq op (consify op))
(csetq keyslist (append keyslist (list (car op))))
(csetq initlist (append initlist (list (list (car op) (cons 'init-keyval op)))))
)
(&required
(pcond
((consp op)
(clet ((trans (transform-sublvars op)))
(csetq sublvars (append sublvars (list (car trans))))
(csetq initlist (append initlist (cdr trans)))))
(t (csetq sublvars (append sublvars (list op))))))
(otherwise
(break (format nil "lambda-args found keyword ~a" keyword)))))
)
(ret (cons sublvars initlist))
))
(defun transform-lambda (patternIn+bodyIn &optional (name (gensym)))
(trace-format "~s ~s" patternIn+bodyIn name)
(clet (
(patternIn (car patternIn+bodyIn))(BodyIn (cdr patternIn+bodyIn))
(sublvars+initlist (transform-sublvars patternIn))
(sublvars (car sublvars+initlist))(initlist (cdr sublvars+initlist)))
(trace-format "~s ~s" sublvars initlist)
;;(BodyBlock (transform-block-return name BodyIn))
;;(pwhen initlist (csetq BodyIn `((clet ,initlist ,@BodyIn))))
(ret `(() ,sublvars (clet ,initlist ,BodyIn)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; packages completed
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(FORCE-PRINT ";; COERCE ...4")
(defun coerce (VALUE RESULT-TYPE)
(CLET ((LEN VALUE)
(VTYPE (TYPE-OF VALUE))
(CLTYPE RESULT-TYPE))
(PWHEN (EQUAL RESULT-TYPE VTYPE)
(ret VALUE))
(FUNLESS (CAND (CONSP CLTYPE)
(CSETQ LEN (SECOND CLTYPE))
(CSETQ CLTYPE (CAR CLTYPE)))
(FIF
(CONSP VALUE)
(CSETQ LEN (LENGTH VALUE))))
(PCASE CLTYPE ('T (ret VALUE))
('SEQUENCE
(FIF
(SEQUENCEP VALUE)
(ret (COPY-SEQ VALUE))
(CSETQ VALUE (WRITE-TO-STRING VALUE)))
(CSETQ CLTYPE (MAKE-VECTOR LEN))
(CDO ((IDX 0 (+ 1 IDX)))
((= IDX LEN)
(ret CLTYPE ))
(SET-AREF CLTYPE IDX (ELT VALUE IDX))))
('CHARACTER
(PCOND
((CHARACTERP VALUE)
(ret VALUE))
((NUMBERP VALUE)
(ret (CODE-CHAR VALUE)))
((STRINGP VALUE)
(ret (CHAR VALUE 0)))
(T (ret (CHAR (COERCE VALUE 'STRING ) 0)))))
('NUMBER
(PCOND
((NUMBERP VALUE)
(ret VALUE))
((CHARACTERP VALUE)
(ret (CHAR-CODE VALUE)))
((STRINGP VALUE)
(ret (STRING-TO-NUMBER VALUE)))
(T (ret (STRING-TO-NUMBER (WRITE-TO-STRING VALUE))))))
('INTEGER (ret (ROUND (COERCE VALUE 'NUMBER))))
('FIXNUM (ret (ROUND (COERCE VALUE 'NUMBER))))
('FLOAT (ret (FLOAT (COERCE VALUE 'NUMBER))))
('REAL (ret (FLOAT (COERCE VALUE 'NUMBER))))
('FLONUM (ret (FLOAT (COERCE VALUE 'NUMBER))))
('STRING
(PCOND
((STRINGP VALUE)
(ret VALUE))
((CHARACTERP VALUE)
(ret (MAKE-STRING 1 VALUE)))
((SEQUENCEP VALUE)
(CSETQ CLTYPE (MAKE-STRING LEN))
(CDO ((IDX 0 (+ 1 IDX)))
((= IDX LEN)
(ret CLTYPE ))
(SET-AREF CLTYPE IDX (COERCE (ELT VALUE IDX) 'CHARACTER))))
(T (ret (WRITE-TO-STRING VALUE)))))
('LIST
(PCOND
((LISTP VALUE)
(ret LIST))
((SEQUENCEP VALUE)
(CSETQ CLTYPE NIL)
(CDO ((IDX LEN (- IDX 1)))
((= IDX 0)
(ret CLTYPE ))
(CSETQ CLTYPE (CONS (ELT VALUE IDX) CLTYPE))))
(T (CSETQ CLTYPE NIL)
(CSETQ VALUE (WRITE-TO-STRING VALUE))
(CDO ((IDX LEN (- IDX 1)))
((= IDX 0)
(ret CLTYPE ))
(CSETQ CLTYPE (CONS (ELT VALUE IDX) CLTYPE))))))
('CONS
(PCOND
((LISTP VALUE)
(ret LIST))
((SEQUENCEP VALUE)
(CSETQ CLTYPE NIL)
(CDO ((IDX LEN (- IDX 1)))
((= IDX 0)
(ret CLTYPE ))
(CSETQ CLTYPE (CONS (ELT VALUE IDX) CLTYPE))))
(T (CSETQ CLTYPE NIL)
(CSETQ VALUE (WRITE-TO-STRING VALUE))
(CDO ((IDX LEN (- IDX 1)))
((= IDX 0)
(ret CLTYPE ))
(CSETQ CLTYPE (CONS (ELT VALUE IDX) CLTYPE))))))
('KEYPAIR
(PCOND
((ATOM VALUE)
(ret LIST VALUE))
(T (ret (COERCE VALUE 'CONS)))))
('ALIST (CSETQ CLTYPE (CSETQ CLTYPE NIL))
(FIF
(SEQUENCEP VALUE) T (CSETQ VALUE (COERCE VALUE 'SEQUENCE)))
(CDO ((IDX 0 (+ 1 IDX)))
((= IDX LEN)
(ret CLTYPE))
(CSETQ RESULT-TYPE (COERCE (ELT VALUE IDX) 'CONS))
(CSETQ CLTYPE (ACONS (CAR RESULT-TYPE)
(CDR RESULT-TYPE) CLTYPE)))
(ret CLTYPE))
('HASH-TABLE
(FIF
(HASH-TABLE-P VALUE)
(ret VALUE))
(CSETQ CLTYPE (MAKE-HASH-TABLE LEN))
(FIF
(SEQUENCEP VALUE) T (CSETQ VALUE (COERCE VALUE 'SEQUENCE)))
(CDO ((IDX 0 (+ 1 IDX)))
((= IDX LEN)
(ret CLTYPE))
(PRINT (LIST 'COERCE VALUE RESULT-TYPE CLTYPE LEN (ELT VALUE IDX)))
(CSETQ RESULT-TYPE (COERCE (ELT VALUE IDX) 'KEYPAIR))
(SETHASH (CAR RESULT-TYPE) CLTYPE (CDR RESULT-TYPE))))
(OTHERWISE (ret VALUE)))
(THROW :COERCE (LIST VALUE RESULT-TYPE)))
(ret VALUE))
(FORCE-PRINT ";; CATCH ...4")
(defmacro CATCH (TAG &BODY BODY)
(ret `(APPLY #'VALUES
(CLET ((*THROWN* :UNTHROWN)
(*RESULT* :UNEVALED))(TERPRI)
(CCATCH ,TAG *THROWN* (CSETQ *RESULT* (MULTIPLE-VALUE-LIST (PROGN ,@BODY))))
(PCOND
((EQUAL *RESULT* :UNEVALED)
(LIST *THROWN*))
(T *RESULT*))))))
(import 'CL::DEFINE :CYC)
(import 'CL::DEFINE :CYC)
(import 'CL::DEFMACRO :CYC)
(import 'CL::DEFMACRO :CYC)
(defmacro CL-LOOP (&REST EXPS)
;;"SUPPORTS BOTH ANSI AND SIMPLE LOOP. WARNING: NOT EVERY LOOP KEYWORD IS SUPPORTED."
(FORMAT T "~%~S~%" `(LOOP ,@EXPS))(FORCE-OUTPUT)
(PUNLESS (MEMBER-IF #'SYMBOLP EXPS) (ret `(LOOP ,@EXPS)))
(PCASE (CAR EXPS)
((UNTIL WHILE) (ret EXPS))
(FOR (BREAK "CL::LOOP"))
(REPEAT (BREAK "CL::LOOP"))
(OTHERWISE (ret `(LOOP ,@EXPS)))))
;;(defmacro LOOP (&REST FORMS) (ret `(LOOP ,@FORMS)))
(defun BREAK-STRING-AT (STRING BREAK-CHAR)
(FUNLESS (STRING= STRING "")
(CLET ((CHARAT (POSITION BREAK-CHAR STRING)))(ret (FIF CHARAT (CONS (SUBSEQ STRING 0 CHARAT)
(BREAK-STRING-AT (SUBSEQ STRING (+ 1 CHARAT)) BREAK-CHAR)) (LIST STRING))))))
(defun BINDINGS-FOR (PATTERN)
(CLET ((COLLECT ()))
(DOLIST (VAR (VARIABLES-IN PATTERN))
(SETQ COLLECT (APPEND COLLECT (LIST (CDR (ASSOC VAR *BINDINGS*))))))
(ret COLLECT)))
(defun COMPILE-RULES (RULES VAR)
;;"A RULES IS OF THE FORM (PAT CODE) WHERE CODE MAY REFERENCE VARS IN PAT."
(CLET ((COLLECT ()))
(DOLIST (PATTERN+CONSEQUENT RULES)
(CSETQ COLLECT (APPEND COLLECT (LIST (COMPILE-RULE (FIRST PATTERN+CONSEQUENT)(SECOND PATTERN+CONSEQUENT) VAR)))))
(ret (CREDUCE #'MERGE-CODE COLLECT))))
;;transliterations
;;make-process-with-args (name function &optional args)
;;expand-define-list-element-predicator (function-name function-scope element-var type body)
;;argnames-from-arglist
;;(defmacro until (test &body body)"repeatedly evaluate body until test is true."(ret `(do ()(,test) ,@body)))
;;(defmacro setf (&rest pairs) (pwhen pairs `(progn (_setf ,(car pairs) (trace-progn ,(cadr pairs)))(setf ,@(cddr pairs)))))
;;(defmacro or (&rest body) (ret (fif body (fif (cdr body) `(pcond ((trace ,(car body))) ((or ,@(cdr body))))`(trace ,(car body))))))
;;(defmacro incf (arg1 &body body) (ret `(fif (null body) (cincf arg1) (progn (cincf ,@body) ,@body)))
;;(defmacro concat (&rest body) (ret `(progn (mapfuncall #'(lambda (x) (if (not (stringp x)) (trace (cons 'concat ',body)))) ,body)(apply #'cconcatenate (cons "" ,body)))))
;;(defmacro cmultiple-value-list (value &rest ignore)(ret `(multiple-value-list ,value)))
;;(defmacro case (test &rest body) (ret (cons 'pcase (cons `,test (mapfuncall #'(lambda (x) (ret `(,(car x)(trace-progn ,(cdr x))) )) body)))))
(defvar internal-time-units-per-second *internal-time-units-per-second*)
(defvar *eval-mode* (list :load-toplevel :execute) )
(defun typep (form type) (ret (cor (eq type t)(same-classes (type-of form) type))))
(defun some-list (fn seq) (ret (pwhen (car seq) (cor (apply fn (mapfuncall #'car seq)) (some-list fn (mapfuncall #'cdr seq))))))
(defun some (fn &rest seq) (ret (some-list fn seq)))
(defun same-classes (current target) (ret (equal current target)))
(defun puthash (key value table) (ret (sethash key table value)))
(defun map-sequences (function sequences)(ret (fif(member () sequences) ()(cons (apply function (mapcar #'car sequences))(map-sequences function (mapcar #'cdr sequences))))))
(defun map-sequences (function sequences)(ret (fif (member () sequences) () (cons (apply function (mapfuncall #'car sequences)) (map-sequences function (mapfuncall #'cdr sequences))))))
(defun map (result-type function &body sequences)(ret (fif result-type (coerce (map-sequences function sequences) result-type) (progn (map-sequences function sequences) nil))))
(defun make-string (&rest rest)(ret (make-string (find 'numberp rest #'funcall)(find #'characterp rest 'funcall))))
(defun make-array (&rest rest)(clet ((size (find 'numberp rest #'funcall)))(ret (make-vector(fifsize size 64)(find #'functionp rest 'funcall)))))
(defun explode (string) (funless (string= string "") (clet ((result ())(len (length string)))(cdo ((ndx (- len 1) (- ndx 1))(result (cons (char string ndx) result)(cons (char string ndx) result))) ((= ndx 0)(ret result))))))
(defun every-list (fn seq) (ret (fif (car seq) (cand (apply fn (mapfuncall #'car seq)) (every-list fn (mapfuncall #'cdr seq))) t)))
(defun every (fn &rest seq) (ret (every-list fn seq)))
(defun concat (&rest list)(ret (apply #'cconcatenate (cons "" (mapfuncall #'(lambda (x)(ret (fif (stringp x) x (coerce x 'string) ))) (flatten list))))))
(defun concat (&rest list) (ret (apply #'cconcatenate (cons "" (mapfuncall #'(lambda (x) (ret (if (stringp x) x (coerce x 'string) ))) list)))))
(defun cl-make-hash-table (&rest lkeys)(clet (test size rehash-size rehash-threshold)(init-keyval size 64)(init-keyval test #'eql)(break "make-hash-table")(ret (#>sl::make-hash-table size test))))
(defmacro when (cond &rest body) (ret `(pwhen (trace ,cond) (trace-progn ,@body))))
(defmacro unwind-protect (protected &rest rest) (ret `(clet ((pvalues ()))(cunwind-protect (csetq pvalues (cmultiple-values-list (trace ,protected)) (trace-progn ,@rest))) (values-list pvalues))))
(defmacro unless (cond &rest body) (ret `(punless (trace ,cond) (trace-progn ,@body))))
(defmacro svref (array idx) (ret `(aref ,array ,idx)))
(defmacro setq (&rest pairs) (pwhen pairs `(progn (csetq ,(car pairs) (trace-progn ,(cadr pairs)))(setq ,@(cddr pairs)))))
(defmacro setf (&rest pairs) (pwhen pairs `(progn (csetf ,(car pairs) (trace-progn ,(cadr pairs)))(setq ,@(cddr pairs)))))
(defmacro return-from (name value) (ret `(ret ,value)))
(defmacro pushnew (item place &key key test test-not) (ret (fif test (list 'cpushnew item place test)(list 'cpushnew item place))))
(defmacro push (item place) (ret `(progn (cpush ,item ,place) ,place)))
(defmacro push (item place &key key test test-not) (ret (fif test (list 'cpush item place test)(list 'cpush item place))))
(defmacro prog3 (body1 body2 body3 &rest body) (ret `(clet ((prog1res (trace ,body1))(prog2res (trace ,body2))(prog3res (trace ,body3))) (trace-progn ,@body) prog3res)))
(defmacro prog2 (body1 body2 &rest body) (ret `(clet ((prog1res (trace ,body1))(prog2res (trace ,body2))) (trace-progn ,@body) prog2res)))
(defmacro prog1 (body1 &rest body) (ret `(clet ((prog1res (trace ,body1))) (trace-progn ,@body) prog1res)))
(defmacro pop (place) (ret `(clet ((f1rst (car ,place))) (cpop ,place) f1rst)))
(defmacro or (&rest body) (ret (fif body (fif (cdr body) `(pcond ((trace ,(car body))) ((or ,@(cdr body))))`(trace ,(car body))))))
(defmacro not (&rest body) (ret `(cnot ,@body)))
(defmacro multiple-value-bind (var+list form &rest body) (ret `(cmultiple-value-bind ,var+list ,form (trace-progn ,@body))))
(defmacro memq (item list) (ret `(member ,item ,list #'eq)))
(defmacro memq (item my-list) `(member ,item ,my-list :test #'eq))
(defmacro make-array (size &key initial-element ) (ret `(make-vector ,size ,initial-element)))
(defmacro let* (var+list &rest body) (ret `(clet (,@(mapfuncall #'trace-varinit var+list)) (trace-progn ,@body))))
(defmacro let (var+list &rest body) (ret `(clet (,@(mapfuncall #'trace-varinit var+list)) (trace-progn ,@body))))
(defmacro incf (&body body) (ret `(cinc ,@body)))
(defmacro if (cond true &optional (else nil)) (ret `(fif (trace ,cond) (trace ,true) (trace ,else))))
(defmacro handler-case (form &rest cases) (ret form))
(defmacro eval-when (when &body body) (ret `(if (intersection ',when *eval-mode*) (progn ,@body))))
(defmacro eval-when ((&rest whens) &rest body) `(trace-progn ,@body))
(defmacro dotimes (var integer &rest body) (ret `(cdotimes ,var (trace ,integer) (trace-progn ,@body))))
(defmacro dolist (var+list &rest body) (ret `(cdolist (,(car var+list) ,(second var+list)) (trace-progn ,@body))))
(defmacro do-symbols (var pack &rest body) (ret `(cdo-symbols (,var pack) (trace-progn ,@body))))
(defmacro do-external-symbols (var pack &rest body) (ret `(cdo-external-symbols (,var pack) (trace-progn ,@body))))
(defmacro do-all-symbols (var &rest body) (ret `(cdo-all-symbols ,var (trace-progn ,@body))))
(defmacro do (var+list exit &rest body) (ret `(cdo (,@(mapfuncall #'trace-varinit var+list)) ,(trace-each exit) (trace-progn ,@body))))
(defmacro destructuring-bind (pattern datum &rest body)(ret `(cdestructuring-bind ,pattern ,datum (trace-progn ,@body))))
(defmacro destructuring-bind (args datum &body body)(ret `(cdestructuring-bind ,args ,datum ,@body)))
(defmacro destructuring-bind (args datum &body body) (ret `(cdestructuring-bind ,args ,datum ,@body)))
(defmacro defsetf (access-fn update-fn) (ret `(sublisp::_def-csetf ',access-fn ',update-fn)))
(defmacro decf (&body body) (ret `(cdec ,@body)))
(defmacro cond (&rest forms) (ret `(pcond ,@forms)))(defmacro or (&rest forms) (ret (fif forms (fif (cdr forms) `(pcond ((trace ,(car forms))) ((or ,@(cdr forms))))`(trace ,(car forms))))))
(defmacro cond (&rest forms) (ret (cons 'pcond (mapcar #'(lambda (x) (ret `(,(car x)(trace-progn ,(cdr x))) )) forms) )))
(defmacro cond (&rest body) (ret (cons 'pcond (mapfuncall #'(lambda (x) (ret `( ,@(mapfuncall #'(lambda (xz) (ret `(trace ,xz))) x)))) body))))
(defmacro concatenate (cltype &body args)(ret `(coerce (cconcatenate ,@args) ,cltype)))
(defmacro concatenate (cltype &body args) (ret `(coerce (cconcatenate ,@args) ,cltype)))
(defmacro cmultiple-value-list (value &rest ignore) (ret `(multiple-value-list ,value)))
(defmacro cl::defstruct (name &rest rest)(clet ((slots (mapcar #'(lambda(x)(ret (fif(atom x) x (car x)))) rest)))(ret `(defstruct (,name) ,@slots))))
(defmacro case (test &rest forms) (ret `(pcase ,test ,@forms)))
(defmacro case (test &rest forms) (ret `(pcase ,test ,(mapcar #'(lambda (x) (ret `(,(car x)(trace-progn ,(cdr x))) )) forms))))
(defmacro case (test &rest body) (ret `(pcase ,(trace test) ,@(mapfuncall #'(lambda (x) (ret `(,(car x) (trace-progn ,@(cdr x))) )) body))))
(defmacro case (&rest forms) (ret (cons 'pcase forms)))
(defmacro assert (test &rest body))
(defmacro and (&rest forms) (ret (fif forms (fif (cdr forms) `(pwhen (trace ,(car forms)) (and ,@(cdr forms)))`(trace ,(car forms))))))
(defmacro and (&rest body) (ret (fif body (fif (cdr body) `(pwhen (trace ,(car body)) (and ,@(cdr body)))`(trace ,(car body))))))
(defmacro GETLKEY (KEY &OPTIONAL DEFAULT)
(ret
`(CSETQ ,KEY
(PCOND
((CAR (CDR (MEMBER-IF #'(lambda (X)(ret (CAND (SYMBOLP X)(SYMBOLP ,KEY)(EQUAL (SYMBOL-NAME X) (SYMBOL-NAME ,KEY))))) LKEYS))))
(T ,DEFAULT)))))
(defun MEMBER (ITEM LIST &REST LKEYS)
(TRACE-DEFUN 'CL::MEMBER (ITEM LIST '&REST LKEYS)())
(CLET (TEST KEY TEST-NOT)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)
(FUNLESS TEST (CSETQ TEST #'EQL))
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(ret (MEMBER ITEM LIST TEST KEY))))
(defun INTERSECTION (LIST-1 LIST-2 &REST LKEYS)
(TRACE-DEFUN 'CL::INTERSECTION (LIST-1 LIST-2 '&REST LKEYS)())
(CLET (TEST KEY TEST-NOT)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(FUNLESS TEST (CSETQ TEST #'EQL))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(ret (INTERSECTION LIST-1 LIST-2 TEST KEY ))))
(defun REMOVE (ITEM LIST &REST LKEYS )
(TRACE-DEFUN 'CL::REMOVE (ITEM LIST '&REST LKEYS)())
(CLET (TEST FROM-END TEST-NOT START END COUNT KEY)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)(GETLKEY FROM-END)(GETLKEY START)(GETLKEY END)(GETLKEY COUNT)
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(FUNLESS TEST (CSETQ TEST #'EQL))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(FUNLESS START (CSETQ START 0))
(PWHEN FROM-END (ret (REVERSE (REMOVE ITEM (REVERSE LIST) TEST KEY START END COUNT))))
(ret (REMOVE ITEM LIST TEST KEY START END COUNT))))
(defun REMOVE-DUPLICATES (LIST &REST LKEYS)
(TRACE-DEFUN 'CL::REMOVE-DUPLICATES (LIST '&REST LKEYS) ())
(CLET (TEST FROM-END TEST-NOT START END COUNT KEY)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)(GETLKEY FROM-END)(GETLKEY START)(GETLKEY END)(GETLKEY COUNT)
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(FUNLESS TEST (CSETQ TEST #'EQL))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(FUNLESS START (CSETQ START 0))
(PWHEN FROM-END (ret (REVERSE (REMOVE-DUPLICATES (REVERSE LIST) TEST KEY START END))))
(ret (REMOVE-DUPLICATES LIST TEST KEY START END))))
(defun DELETE-DUPLICATES (LIST &REST LKEYS)
(TRACE-DEFUN 'CL::DELETE-DUPLICATES (LIST '&REST LKEYS)())
(CLET (TEST FROM-END TEST-NOT START END COUNT KEY)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)(GETLKEY FROM-END)(GETLKEY START)(GETLKEY END)(GETLKEY COUNT)
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(FUNLESS TEST (CSETQ TEST #'EQL))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(FUNLESS START (CSETQ START 0))
(PWHEN FROM-END (ret (REVERSE (DELETE-DUPLICATES (REVERSE LIST) TEST KEY START END))))
(ret (DELETE-DUPLICATES LIST TEST KEY START END))))
(defun SUBSETP (LIST LIST2 &REST LKEYS)
(TRACE-DEFUN 'CL::SUBSETP (LIST LIST2 '&REST LKEYS)())
(CLET (TEST KEY TEST-NOT)
(GETLKEY TEST)(GETLKEY KEY)(GETLKEY TEST-NOT)
(FUNLESS KEY (CSETQ KEY #'IDENTITY))
(FUNLESS TEST (CSETQ TEST #'EQL))
(PWHEN TEST-NOT (CSETQ TEST #'(lambda (X Y)(ret (CNOT (FUNCALL TEST-NOT X Y))))))
(ret (SUBSETP LIST LIST2 TEST KEY))))
;;(defun GET (SYM PROP);;(PRINT `(GET ,SYM ,PROP ,(GET SYM PROP)))
;; (ret `(GET ,SYM ,PROP)))
;;(defun SET (SYM PROP VAL) (PRINT `(SET ,SYM ,PROP ,VAL))(ret `(SET ,SYM ,PROP ,VAL)))
;;(defun GET (SYM PROP) (ret `(GET ,SYM ,PROP )))
;;(defun SET (SYM PROP VAL) (ret `(SET ,SYM ,PROP ,VAL)))
;;(defmacro UNLESS (&REST REST) (ret `(ret (PROGN (PRINT ',FORM) ,FORM))))
;;(defmacro SUBLISP-INITVAR (VAR VALUE) (ret `(FUNLESS ,VAR (CSETQ ,VAR ,VALUE))))
(defun STRING-DOWNCASE (STR)
(ret (PCOND
((SYMBOLP STR)
(STRING-DOWNCASE (SYMBOL-NAME STR)))
(T (STRING-DOWNCASE STR)))))
#|
(DEFVAR STREAM *STANDARD-INPUT*)
(DEFVAR EOF-VAL :EOF)
(DEFVAR REC-P T)
(DEFVAR EOF-ERR-P NIL)
(defmacro USER-WARNING (STRING &REST ARGS)
(ret `(FORMAT T ,STRING ,@ARGS)))
(defmacro USER-ERROR (STRING &REST ARGS)
(ret `(FORMAT T ,STRING ,@ARGS)))
|#
(defun EQUAL (&REST REST)
(TRACE-FORMAT "~S~%" `(EQUAL ,@REST))
(ret (EQUAL (CAR REST) (CAR (CDR REST)))))
(defun MY-CONCAT (&REST REST) (ret (APPLY #'CONCAT REST)))
(defun KMP ()
(CSETF (READTABLE-CASE *READTABLE*) :UPCASE)
(load "common_lisp.lisp")
(load "kmp.subl")
(load "common_lisp.lisp")
;;(CSETF (READTABLE-CASE *READTABLE*) :PRESERVE)
)
#|
CREATE-INSTANCE
ISA
ALL-INSTANCES
COMMENT
LOAD-KB
FLATTEN
ASSOC-EQUAL
ORDERED-SET-DIFFERENCE
ORDERED-INTERSECTION
QUOTIFY
PERMUTE
TRIM-WHITESPACE
FIRST-CHAR
LAST-CHAR
ENDS-WITH
STARTS-WITH
STRING-TO-NUMBER
|#
(defun lisp ()
(print '(LOAD "c.lisp"))
(clet ((expr ())(fs (OPEN-TEXT "c.lisp" :input)))
(cdo ((expr (read fs nil :EOF)(read fs nil :EOF))) ((equal expr :EOF) (close fs))
(print (FILE-POSITION fs))
(punless (equal '(lisp) expr) (cadr expr) (eval expr)))))
(FORCE-PRINT ";; SUBLISP ...4")
;;(defmacro MULTIPLE-VALUE-BIND (var+list form &rest body) (ret `(CMULTIPLE-VALUE-BIND ,var+list (trace ,form) (trace-progn ,@body))))
;;(macroexpand '(if a b c))
;;(macroexpand '(defmacro if (cond true &optional (else nil)) (ret `(fif (trace ,cond) (trace ,true) (trace ,else)))))
;;(clet ((edebug `(,'intern ,'@args)(*LISP-stack* (cons edebug *LISP-stack*))))
;; (,intern ,@args))))))))
;;(macroexpand '(if t f e))
(defun package-info (&optional (package *PACKAGE*) property)
#|
(csetq package (coerce-package package))
(clet ((info (intern "info" package)))
(punless (symbol-value info)
(put info :name (package-name package))
(put info :nicknames (package-nicknames package))
(put info :use-list (package-use-list package))
(put info :used-by-list (package-used-by-list package))
(put info :shadowing-symbols (package-shadowing-symbols package))
(put info :external ())
(put info :inherited ())
(put info :internal ())
(put info :missing ())
(put info :aliased ())
(put info :imported ())
(put info :searched ())
(put info :self package)
(CDO-SYMBOLS (sym package)
(CMULTIPLE-VALUE-BIND (found status) (find-symbol (symbol-name sym) package)
(fif found
(progn
(punless (eq (symbol-package found) package) (cpushnew found (get info :imported)))
(cpush found (get info (fif status status :missing))))
(progn
(pushnew sym (get info :searched))
(punless (eq (symbol-package sym) package) (cpushnew sym (get info :imported)))
(cpush sym (get info (fif status status :missing)))))))
(csetf (symbol-value info) info))
(ret (fif property (get info property) info)))|#)
(defun safe-value (symbol)
(cand (symbolp symbol)(boundp symbol)(ret (symbol-value symbol)))
(ret symbol))
(defun safe-car (list) (ret (fif (consp list)(car list) list)))
(defun safe-cdr (list) (ret (fif (consp list)(cdr list) list)))
(defvar *describing* ())
(defun describe (info &optional string)
(pwhen (null string) (csetq string (fif info (format nil "~%; ~a" (type-of info)) "~%; ")))
(punless (stringp string) (csetq string (format nil "~%; ~s" string)))
(punless (char= (char string 0) #\Newline) (csetq string (format nil "~%; ~a" string)))
(clet ((desc (assoc info *describing*))(*describing* (acons info string *describing*)))
(pcond
((cnot (null desc))
(trace-format"~a was described as ~s " string (car desc)))
((null info)
(trace-format"~a is NULL" string ))
((consp info)
(fif (> (length info) 20)
(trace-format"~a length ~a starts with ~s ... " string (length info) (subseq info 0 20))
(trace-format"~a => ~s" string info)))
((stringp info)
(trace-format"~a => ~s" string info))
((packagep info)
(trace-format"~a => (find-package ~s)" string (coerce-string info)))
((numberp info)
(trace-format"~a => ~s" string info))
((keywordp info)
(trace-format"~a => ~s" string info))
((symbolp info)
(clet ((string (format nil "~a => |~a|" string (symbol-name info))))
(trace-format"~a package: ~a" string (coerce-string (symbol-package info)))
(pwhen (fboundp info) (trace-format"~a is fboundp" string))
(fif (boundp info)
(describe (symbol-value info) (format nil "~a value: " string))
(trace-format"~a value: unbound" string))
(cdo ( (kvs (symbol-plist info)(cddr kvs))
(key (car kvs)(car kvs))
(value (cadr kvs)(cadr kvs)))
((null kvs))
(describe value (format nil "~a ~s" string key)))))
(t
(trace-format"~a => ~s" string info))))
(fresh-line))
(defun describe-package (&optional (package *PACKAGE*) property)
(csetq package (coerce-package package))
;;(symbol-value (find-))
(describe (package-info package property) (format nil "(PACKAGE-~a ~s)" (fif property property :INFO) (package-name package))))
;;(ret package))
(FORCE-PRINT ";; package ...4")
(defun import (symbol package)
;;(del-package-info package :internal symbol)
(add-package-info package :imported symbol)
(ret (import symbol package)))
(defun del-package-info (package property symbol)
(delete symbol (get (package-info package) property)))
(defun add-package-info (package property symbol)
(cpushnew symbol (get (package-info package) property)))
(defun export (symbol package)
;;(add-package-info package :external symbol)
;; (del-package-info package :internal symbol)
(ret (EXPORT symbol package)))
(defun unexport (symbol package)
;;(del-package-info package :external symbol)
;;(add-package-info package :internal symbol)
(ret (unexport symbol package)))
(defun intern (symbol package)
(csetq symbol (multiple-value-list (intern symbol package)))
(add-package-info package :internal (car symbol))
(ret (values-list symbol)))
(defun unintern (symbol package)
(clet ((sympack (symbol-package symbol)))
(trace-warn (unintern symbol package))
;;(del-package-info package :external symbol)
;;(del-package-info package :internal symbol)
(ret (cnot (eq (symbol-package symbol) sympack)))))
(defun unimport (found package)
(import found package)
(trace-warn (unintern found package))
(ret T))
;;(FORCE-PRINT `(transform-lambda ',name ',patternIn ',bodyIn)
;; (punless (listp bodyIn) (break "transform-lambda bodyIn was not list"))
;; (csetq body (transform-block bodyIn 'form name)))
;;ARGNAMES-FROM-ARGLIST
;;(FUNCTION-SYMBOL-ARGLIST '
(defun cdadr (list) (ret (cdr (car (cdr list)))))
(defun last-cdadr (list)
(clet ((next (cdadr list)))
(ret (fif next (last-cdadr next) list))))
;;(transform-lambda '((a &aux (b 1) c) &key (name "douglas") number) (list a b c))
;;(transform-sublvars '((( a &aux b) c))
(FORCE-PRINT ";; funtest ...4")
(defmacro funtest (args &rest body)
(ret (clet ((suggest21 (gentemp)))
(pwhen (stringp (car body)) (csetq body (cdr body)))
(csetq body `((ret (progn ,@body))))
(clet ((pattern+body (transform-lambda (cons args body)))
(sublisppattern (car pattern+body))(progbody (cdr pattern+body)))
(csetq progbody `((trace-tag ,suggest21 ,@progbody)))
(print `(,args))
(print `(,sublisppattern))
(print `(,body))
(print `(,progbody))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;trace-symbol
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun coerce-package (name &optional default)
(ret
(pcond
((packagep name) (ret name))
((find-package (string name)))
((null name) default)
((symbolp name)(ret (coerce-package (symbol-name name)(symbol-package name))))
(t (ret default)))))
(defun coerce-string (sym)
(pcond
((null sym) (ret "NIL"))
((stringp sym) (ret sym))
((symbolp sym) (ret (symbol-name sym)))
((packagep sym) (ret (package-name sym)))
((consp sym))(ret (mapfuncall #'coerce-string sym))
(t (ret (write-to-string sym)))))
(defun MACRO-SYMBOL-ARGLIST (msym)
(clet ((err (FUNCTION-SYMBOL-ARGLIST msym)))
(ret err)
(pwhen err (with-error-handler
#'(lambda ()
(csetq err (search "(" *ERROR-MESSAGE*))
(fif (numberp err)
(csetq err (read-from-string (substring *ERROR-MESSAGE* err)))
(csetq err (list *ERROR-MESSAGE*))))
(eval `(,msym))))
(ret err)))
(defun trace-symbol (symbol &optional (package *PACKAGE*))
(csetq package (coerce-package package nil))
(clet ((packstr (fif package (coerce-string package) "#")))
(pcond
((null symbol) (ret "~a:NIL" packstr))
((consp symbol) (ret (cons (trace-symbol (car symbol) package)(fif (cdr symbol) (trace-symbol (cdr symbol) package) ()))))
((stringp symbol)
(clet ((found (find-symbol symbol (fif (packagep package) package *PACKAGE*))))
(pwhen found (ret (trace-symbol found package)))
(ret (format nil "~a!~~~a" (coerce-string package) symbol))))
((cnot (symbolp symbol)) (ret (write-to-string symbol)))
(t
(clet ((name (symbol-name symbol))(symbolpack (symbol-package symbol)))
(CMULTIPLE-VALUE-BIND (found status) (fif package (find-symbol name package)(find-symbol name))
(pcase status
(NIL
(punless (eq symbolpack package) (ret (format nil "~a~~!~a" packstr (trace-symbol symbol symbolpack))))
(csetq name (format nil "~a:~a" packstr name)))
(:inherited (ret (format nil "~a~~~a" packstr (trace-symbol found (symbol-package found)))))
(:internal (csetq name (format nil "::~a" name)))
(:external (csetq name (format nil ":~a" name))))
(punless (eq symbol found)
(csetq name (format nil "@~a" name))
(csetq symbolpack (symbol-package found))
(csetq symbol found))
(csetq name (format nil "~a~a" (coerce-string symbolpack) name))
(fif (MACRO-OPERATOR-P symbol)
(csetq name (format nil "~a" (cons name (trace-symbol (MACRO-symbol-ARGLIST symbol) symbolpack))))
(fif (FUNCTION-symbol-P symbol)
(csetq name (format nil "~a" (cons name (trace-symbol (FUNCTION-symbol-ARGLIST symbol) symbolpack))))
(pwhen (fboundp symbol)
(csetq name (format nil "(funcall ~s ~a #|~a|#)" (function-value symbol) (cons name (trace-symbol
(FUNCTION-symbol-ARGLIST symbol) symbolpack)) name)))))
(pwhen (boundp symbol)
(fif (keywordp symbol)
(csetq name (format nil "<~a>" name))
(csetq name (format nil "[~a]" name))))
(punless (eq symbolpack package)
(csetq name (format nil "~a->~a" packstr name)))
(ret name)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;trace-progn - Some of the features of the system must be accessable from everywhere
;;Like the
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;CYC(7): (transform-CSETF '(csetf (symbol-function 'book-FIND-all-if) #'remove-if-not))
;;(SUBLISP::_CSETF-SYMBOL-FUNCTION 'BOOK-FIND-ALL-IF (SYMBOL-FUNCTION 'CL::REMOVE-IF-NOT))
;;SUBLISP::_CSETF-SYMBOL-FUNCTION
(defun #>SUBLISP::_CSETF-SYMBOL-FUNCTION (object value)
(eval `(defun ,object (&rest args) (ret (apply ,value args))))
(trace-format "FSET ~s -> ~s (~s)" object value (symbol-function object))
(ret (values value 'symbol-function OBJECT)))
(defmacro fset (&rest body) (ret `(SUBLISP::_CSETF-SYMBOL-FUNCTION ,@body)))
(defsetf SYMBOL-FUNCTION SUBLISP::_CSETF-SYMBOL-FUNCTION)
;;(setf (symbol-function 'book-FIND-all-if) #'remove-if-not)
(defun shadow-push (package sym) )
;;(defmacro let (var+list &rest body) (ret `(clet (,@(mapfuncall #'trace-varinit var+list)) (trace-progn ,@body))))
;;(cdo ((i 0 (1+ i))) ((= i 10))(trace-format"~a,~a" i (constant-name (find-constant-by-internal-id i))))
;;(cdo ((i 0 (1+ i))) ((= i (constant-count)))(trace-format"~a,~a" i (constant-name (find-constant-by-internal-id i))))
(defun use-symbol (symbols &optional (target *package*) (keep #'better-symbol) (inheriting :external))
(csetq target (coerce-package target))
(fif (consp symbols) (ret (mapfuncall #'(lambda (x) (ret (use-symbol x target keep))) symbols))
(punless (cand symbols (symbolp symbols)) symbols))
(clet ((from *package*)(name (symbol-name symbols))(package (symbol-package symbols)))
(CMULTIPLE-VALUE-BIND (sujjest status) (find-symbol name package)
(pwhen (cnot (eq symbols sujjest)) (trace-format" Rotten symbol ~a instead of ~a" (trace-symbol sujjest package)(trace-symbol symbols package)))
(CMULTIPLE-VALUE-BIND (visible tstatus) (find-symbol name target)
(pcond
((null visible))
((eq sujjest visible) (ret (values visible tstatus))) ;; (trace-format"~a ~a" tstatus (trace-symbol sujjest target))
((cand (functionp keep)(eq visible (funcall keep sujjest visible)))
(trace-format" Keeping ~a instead of ~a mode = ~a" (trace-symbol visible target) (trace-symbol sujjest target) status)
(ret (values visible tstatus)))
((null sujjest) (ret (values NIL NIL))) ;; (trace-format"~a ~a" tstatus (trace-symbol sujjest target))
(t
(trace-format" Using ~a instead of ~a mode = ~a" (trace-symbol sujjest target) (trace-symbol visible target) tstatus)
(shadow-push package visible)
(pwhen (equal tstatus :inherited) (CL::import visible target))
(csetq status tstatus)
(trace-warn (CL::unintern visible target)))))
(pcase status
(:internal ;;(trace-format"Interning ~a" (trace-symbol sujjest target))
(import sujjest target)(intern sujjest target))
(:external ;;(trace-format"Exporting ~a" (trace-symbol sujjest target))
(import sujjest target)(intern sujjest target)(CL::export sujjest target))
(:inherited ;;(trace-format"Inheriting ~a" (trace-symbol sujjest target))
(import sujjest target)(CL::export sujjest target)))
(ret (values sujjest status)))))
;;Shadowing-Import -- Public
;;
;; If a conflicting symbol is present, unintern it, otherwise just
;;stick the symbol in.
;;
(defun make-shadow (symbol &optional (package *package*) (internals *sticky-symbols*)(exceptwhen *sticky-symbols*))
;;(break "make-shadow")
(pcond
((null symbol) (ret symbol))
((consp symbol)
(rplaca symbol (make-shadow (car symbol) package internals exceptwhen))
(rplacd symbol (make-shadow (cdr symbol) package internals (append (consify symbol)(consify exceptwhen))))
(ret symbol))
((car (named-member symbol exceptwhen)))
((cor (symbolp symbol)(stringp symbol))
(csetq symbol (coerce-string symbol))
(csetq package (coerce-package package))
;;(clet ((info (package-info package)))
(CMULTIPLE-VALUE-BIND (found status) (find-symbol symbol package)
(pcase status
(NIL
(csetq symbol (intern (make-symbol symbol) package))
;;(trace-format"shadow Adding ~a into ~s" (trace-symbol symbol package) package)
;;(CL::import symbol package)
)
(:inherited
(CL::unimport found package)
(trace-format"shadow Hiding ~a from ~s" (trace-symbol found (symbol-package found)) package)
(csetq symbol (intern (make-symbol symbol) package))
;;(CL::import symbol package)
)
((:external :internal)
(pwhen (eq (symbol-package found) package) (ret found))
;; (rem-package-info package status found)
(trace-format"shadow Removing ~a ~a from ~s" status (trace-symbol found package) package)
(CL::unimport found package)
(csetq symbol (intern (make-symbol symbol) package))
))
(pwhen (named-member symbol internals) (csetq status :internal))
(punless (csetq status :internal)
(EXPORT symbol package)
;;(cpushnew symbol (get info :external))
(trace-format"shadow Exporting ~a from ~s" (trace-symbol symbol package) package)
(ret symbol))
;;(cpushnew symbol (get info :internal))
;;(trace-format"shadow Not Exporting ~a from ~s" (trace-symbol symbol package) package)
(ret symbol)))
(t (ret symbol)))
(ret symbol))
(defun FIND-ALL-SYMBOLS (name &rest lkeys)
(clet ((results (list name)))
(pwhen (symbolp name) (csetq name (symbol-name name)))
(KEYLET ((use (LIST-ALL-PACKAGES))(test #'true))
(cdolist (pack use)
(clet ((sym (find-symbol name pack)))
(pwhen sym (pwhen (funcall test sym) (csetq results (cons sym results))))))
(ret results))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;defun shadow functions and macros
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(lock-package :SYSTEM)
;;Shadow -- Public
;;
;;
(defun shadow (sujjest &optional (package *package*))
"Make an internal symbol in Package with the same name as each of the
specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
If a symbol with the given name is already present in Package, then
the existing symbol is placed in the shadowing symbols list if it is
not already present."
(clet ((name (symbol-name sujjest))(package (coerce-package package)))
(CMULTIPLE-VALUE-BIND (s w) (find-symbol name package)
(pwhen (cor (cnot w) (eq w :inherited))
(csetq s (make-symbol name))
(CL::intern s package))
(shadow-push package s)))
(ret t))
;;Shadowing-Import -- Public
;;
;; If a conflicting symbol is present, unintern it, otherwise just
;;stick the symbol in.
;;
(defun shadowing-import (sym &optional (package *package*))
"Import Symbols into package, disregarding any name conflict. If
a symbol of the same name is present, then it is uninterned.
The symbols are added to the Package-Shadowing-Symbols."
(clet ((package (coerce-package package)))
(CMULTIPLE-VALUE-BIND (s w) (find-symbol (symbol-name sym) package)
(punless (cand w (cnot (eq w :inherited)) (eq s sym))
(pwhen (cor (eq w :internal) (eq w :external))
;;
;;If it was shadowed, we don't want Unintern to flame out...
;;(csetq *all-shadowing-symbols* (remove (cons package s)))
(trace-warn (CL::unintern s package)))
(CL::intern sys package))
(shadow-push package sym)))
(ret t))
(FORCE-PRINT ";; ...111")
(defun package-export-all (&optional package (otherpacks (remove package (list *SUBLISP-PACKAGE* *CYC-PACKAGE*))))
;;(clet ((otherpacks (remove package (list *SUBLISP-PACKAGE* *CYC-PACKAGE*))))
(punless package
(csetq *all-internal-symbols* ())
(ret (package-export-all otherpacks)))
(pwhen (consp package)
(ret (mapfuncall #'package-export-all package)))
(CDO-SYMBOLS (sym package)
(clet ((name (symbol-name sym))(pack (symbol-package sym)))
(CMULTIPLE-VALUE-BIND (found state) (find-symbol name package)
(punless (eq sym found)
(trace-format"package-export-all: ~a -> ~a ~a in ~a " pack name state package))
(pcase state
(:EXTERNAL
;;(trace-format"ALREADY: ~a -> ~a ~a in ~a " pack name state package)
(csetq *all-external-symbols* (cons (cons name (cons package (cons found state))) *all-external-symbols*)))
(:INTERNAL
(fif (fboundp found)
(pwhen (EXPORT found package) (csetq *all-internal-symbols* (cons (cons name (cons package (cons found state))) *all-internal-symbols*)))
(cdolist (p otherpacks)
(CMULTIPLE-VALUE-BIND (ofound ostate) (find-symbol name p)
(pcase ostate
((:INTERNAL NIL)
(pwhen ostate
(fif (boundp ofound)
(pwhen (EXPORT ofound (symbol-package ofound))
(csetq *resolve-symbols* (cons (cons ofound found) *resolve-symbols*))
(trace-format"BOUNDP ~s ~s ~s -> ~s " ostate name pack p))
(trace-format"~s ~s ~s -> ~s " ostate name pack p)))
(csetq *all-internal-symbols* (cons (cons name (cons package (cons found state))) *all-internal-symbols*))
(EXPORT found package))
(:EXTERNAL
(fif (boundp found)
(fif (EXPORT found package) (trace-format"BOUNDP ~s ~s ~s -> ~s " ostate name pack p))
(trace-format"~s ~s ~s -> ~s " ostate name pack p))
(csetq *resolve-symbols* (cons (cons ofound found) *resolve-symbols*)))
(:INHERITED
(pwhen (boundp found) (trace-format"~s ~s ~s -> ~s " ostate name pack p))
)))))))))))
;;(pwhen (boundp found) (trace-format"~s ~s ~s -> ~s " ostate name pack p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;USE-PACKAGE
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun USE-PACKAGE (package &optional (target *package*) (keep #'better-symbol)(inheriting :external) done)
;;(clet ((otherpacks (remove package (list *SUBLISP-PACKAGE* *CYC-PACKAGE*))))
(csetq target (coerce-package target))
(pwhen (consp package) (ret (mapfuncall-with-args #'USE-PACKAGE package target keep inheriting done)))
(csetq package (coerce-package package))
(clet ((info (package-info target)))
(CDO-SYMBOLS (symbol package)
(pwhen (eq package (symbol-package symbol))
(CMULTIPLE-VALUE-BIND (found state) (find-symbol (coerce-string symbol) target)
(punless (cand found (cor (fboundp found)(boundp found)))
(fif (fboundp symbol)
(shadow-operator symbol target)
(import symbol target))))))
(ret info)))
;;(defvar *incompatable* '(create-instance isa all-instances comment arity load-kb
;;flatten assoc-equal ordered-set-difference ordered-intersection quotify permute trim-whitespace first-char
;;last-char ends-with starts-with string-to-number read make-string defmacro string-downcase make-hash-table
;;loop intersection defstruct equal member remove remove-duplicates delete-duplicates subsetp))
;;(csetq symbol (find-symbol name package))
;;(trace-format"Linking ~a to ~a" (trace-symbol symbol package) (trace-symbol targetsym package))
;; (clet ((info (package-info package))) (cpushnew targetsym (get info :aliased)))
(defvar *shadow-package* *common-lisp-package*)
(defun coerce-symbol (symbol)
(pwhen (consp symbol)
(pwhen (find-package (car symbol)) (ret (make-shadow (cdar symbol) (car symbol))))
(pwhen (fboundp (car symbol)) (ret (eval symbol))))
(ret symbol))
(defun use-undefined (symbol package)
(pwhen (fboundp (find-symbol (coerce-string symbol) :CYC))
(ret (make-shadow symbol package)))
(fif (find-symbol (coerce-string symbol) :CYC)
(progn (csetq symbol (find-symbol (coerce-string symbol) :CYC)) (intern symbol *shadow-package*))
(fif (find-symbol (coerce-string symbol) :CL)
(progn (csetq symbol (find-symbol (coerce-string symbol) :CL)))
(progn (csetq symbol (make-shadow symbol *shadow-package*)(intern symbol :CYC)))))
(ret symbol))
#|
(defmacro defun (symbol pattern &rest body)
(clet ((res (transform-lambda (cons pattern body) symbol))
(macrodef `(defun ,symbol ,@(cdr res))))
(pwhen (car res) (csetq macrodef `(progn ,(car res) ,macrodef)))
(ret macrodef)))
;;(defun iota (n) (clet (foo) (cdotimes (var n) (csetq foo (append foo (list var)))) foo ))
(defmacro defmacro (symbol pattern &rest body)
(clet ((res (transform-lambda (cons pattern body) symbol))
(macrodef `(defmacro ,symbol ,@(cdr res))))
(pwhen (car res) (csetq macrodef `(progn ,(car res) ,macrodef)))
(ret macrodef)))
(defmacro lambda (pattern &rest body)
(clet ((res (transform-lambda (cons pattern `((ret (progn ,@body)))) NIL))
(macrodef `#'(lambda ,@(cdr res))))
(pwhen (car res) (csetq macrodef `(progn ,(car res) ,macrodef)))
(ret macrodef)))
|#
(defvar *sublisp-missing* '(defun or))
(defvar *missing* '(defun ))
(defvar *verbatum* '(symbol-function))
(defvar internal-time-units-per-second *internal-time-units-per-second*)
(defconstant most-positive-fixnum *most-positive-fixnum* "is that fixnum closest in value to positive infinity provided by the implementation, and greater than or equal to both 2^15 - 1 and array-dimension-limit.")
(defconstant most-negative-fixnum *most-negative-fixnum* "is that fixnum closest in value to negative infinity provided by the implementation, and less than or equal to -2^15")
(defmacro catch (tag &rest body)
(ret `(values-list (clet ((*thrown* :unthrown)
(*LISP-frame-result* :unevaled))
(ccatch ,tag *thrown* (csetq *LISP-frame-result* (multiple-value-list (trace-progn ,@body))))
(fif (equal *LISP-frame-result* :unevaled) (list *thrown*) *LISP-frame-result*)))))
(defun map-sequences (function sequences)
(ret (fif
(member () sequences) ()
(cons (apply function (mapfuncall #'car sequences))
(map-sequences function (mapfuncall #'cdr sequences))))))
(defun map (result-type function &rest sequences)
(ret (fif result-type (coerce (map-sequences function sequences) result-type)
(progn (map-sequences function sequences) nil))))
(FORCE-PRINT ";; ...3")
(defvar *coerce-methods* (make-hash-table 32))
(defun coerce (value result-type &optional (subclassfn #'same-classes))
(clet ((vtype (type-of value))
(len value)
(cltype result-type)
(howto (gethash result-type *coerce-methods*)))
(pwhen (equal result-type vtype) (ret value))
(pwhen howto
(progn
(csetq howto (pcond ((assoc vtype howto subclassfn))((assoc 't howto))))
(pwhen howto
(ret (eval
`(clet ((value ',value)(result-type ',result-type)(vtype ',vtype))
,(cdr howto)))))))
(funless (cand (consp cltype)
(csetq len (second cltype))
(csetq cltype (car cltype)))
(fif
(consp value)
(csetq len (length value))))
(pcase cltype ('t (ret value))
('sequence
(fif
(sequencep value)
(ret (copy-seq value))
(csetq value (write-to-string value)))
(csetq cltype (make-vector len))
(cdo ((idx 0 (+ 1 idx)))
((= idx len)
(ret cltype ))
(set-aref cltype idx (elt value idx))))
('character
(pcond
((characterp value)
(ret value))
((numberp value)
(ret (code-char value)))
((stringp value)
(ret (char value 0)))
(t (ret (char (coerce value 'string ) 0)))))
('number
(pcond
((numberp value)
(ret value))
((characterp value)
(ret (char-code value)))
((stringp value)
(ret (string-to-number value)))
(t (ret (string-to-number (write-to-string value))))))
('integer (ret (round (coerce value 'number))))
('fixnum (ret (round (coerce value 'number))))
('float (ret (float (coerce value 'number))))
('real (ret (float (coerce value 'number))))
('flonum (ret (float (coerce value 'number))))
('string
(pcond
((stringp value)
(ret value))
((characterp value)
(ret (make-string 1 value)))
((sequencep value)
(csetq cltype (make-string len))
(cdo ((idx 0 (+ 1 idx)))
((= idx len)
(ret cltype ))
(set-aref cltype idx (coerce (elt value idx) 'character))))
(t (ret (write-to-string value)))))
('list
(pcond
((listp value)
(ret list))
((sequencep value)
(csetq cltype nil)
(cdo ((idx len (- idx 1)))
((= idx 0)
(ret cltype ))
(csetq cltype (cons (elt value idx) cltype))))
(t (csetq cltype nil)
(csetq value (write-to-string value))
(cdo ((idx len (- idx 1)))
((= idx 0)
(ret cltype ))
(csetq cltype (cons (elt value idx) cltype))))))
('cons
(pcond
((listp value)
(ret list))
((sequencep value)
(csetq cltype nil)
(cdo ((idx len (- idx 1)))
((= idx 0)
(ret cltype ))
(csetq cltype (cons (elt value idx) cltype))))
(t (csetq cltype nil)
(csetq value (write-to-string value))
(cdo ((idx len (- idx 1)))
((= idx 0)
(ret cltype ))
(csetq cltype (cons (elt value idx) cltype))))))
('keypair
(pcond
((atom value)
(ret list value))
(t (ret (coerce value 'cons)))))
('alist (csetq cltype (csetq cltype nil))
(fif
(sequencep value) t (csetq value (coerce value 'sequence)))
(cdo ((idx 0 (+ 1 idx)))
((= idx len)
(ret cltype))
(csetq result-type (coerce (elt value idx) 'cons))
(csetq cltype (acons (car result-type)
(cdr result-type) cltype)))
(ret cltype))
('hash-table
(fif
(hash-table-p value)
(ret value))
(csetq cltype (make-hash-table len))
(fif
(sequencep value) t (csetq value (coerce value 'sequence)))
(cdo ((idx 0 (+ 1 idx)))
((= idx len)
(ret cltype))
(print (list 'coerce value result-type cltype len (elt value idx)))
(csetq result-type (coerce (elt value idx) 'keypair))
(sethash (car result-type) cltype (cdr result-type))))
(otherwise (ret value)))
(throw :coerce (list value result-type)))
(ret value))
(FORCE-PRINT ";; ...4")
#|
;;Initialize the task processor pool for requests.
(INITIALIZE-API-TASK-PROCESSORS)
;;Initialize the task processor pool for requests.
(INITIALIZE-BG-TASK-PROCESSORS )
;;Initialize the task processor pool for requests.
(INITIALIZE-CONSOLE-TASK-PROCESSORS )
(SHOW-API-TASK-PROCESSORS )
;;Provides a convenient alias for DISPLAY-API-TASK-PROCESSORS.
(SHOW-API-TP-MSGS )
;;Show and reset the task processor background messages for thetask-process-pool.
(SHOW-BG-TP-MSGS )
;;Show and reset the task processor background messages for thetask-process-pool.
(SHOW-CONSOLE-TP-MSGS )
;;(TRANSLATOR-RET-OPTIMIZE-BODY )
|#
;;(defun dispatch-macro-IN-PACKAGE (s c n))
(defun structurep (object)
(ret (_structures-bag-p object)))
(defun structure-type (object)
(ret (_structure-slot object 1)))
#|
(punless (member :CYC-COMMON-SYSTEM *features*)
(cpushnew :CYC-COMMON-SYSTEM *features*)
(print '(LOAD "common-lisp.lisp"))
;;(IN-PACKAGE "SYSTEM")
(fif (cand nil (yes-or-no-p) )
(progn
(LOAD "common-lisp.lisp")
;; (USE-PACKAGE '(:CYC :SL) :SYSTEM #'better-symbol)
;; (IN-PACKAGE "LISP")
(terpri))
(progn
;;(IN-PACKAGE "SYSTEM")
;;(print (trace 1) (package-shadowing-symbols (find-package "SYSTEM")))
(terpri))))
|#
(defun unquote (sym)
(pwhen (consp sym)
(pwhen (equal 'QUOTE (car sym))) (ret (second sym)))
(ret sym))
(defmacro defalias (symbol targetsym &optional docstring)
(ret `(defmacro ,(unquote symbol) (&rest args) (ret (cons ',(unquote targetsym) args)))))
(defalias defconst defconstant)
(defmacro shadow-operator (symbol &optional (package *shadow-package*) (targetsym symbol))
(punless (packagep package) (csetq targetsym package))
;;(BREAK " ~s " `(defalias ',symbol ',targetsym))
;;(csetq symbol (make-shadow symbol package))
(ret `(defalias ',symbol ',targetsym)))
#|
(shadow-operator 'defmacro :CL 'CL::defmacro)
(shadow-operator 'lambda :CL 'CL::lambda)
(defmacro shadow-macro (symbol pattern &rest body)
(csetq symbol (use-undefined symbol *shadow-package*))
(ret `(defmacro ,symbol ,pattern ,@body)))
(defmacro shadow-defun (symbol pattern &rest body)
(csetq symbol (use-undefined symbol *shadow-package*))
(ret `(CL::defun ,symbol ,pattern ,@body)))
|#
#|
;;(iota 9)
;;(defmacro destructuring-bind (pattern datum &rest body)(ret `(cdestructuring-bind ,pattern ,datum ,@body)))
;;(defmacro CMULTIPLE-VALUE-BIND (pattern datum &rest body)(ret `(CMULTIPLE-VALUE-BIND ,pattern ,datum ,@body)))
;;(defmacro cmultiple-value-list (value &rest ignore)(ret `(multiple-value-list ,value)))
(defmacro concatenate (cltype &rest pattern) (ret `(coerce (cconcatenate ,@pattern) ,cltype)))
(defun concat (&rest list) (ret (apply #'cconcatenate (cons "" (mapfuncall #'(lambda (x)(ret (fif (stringp x) x (coerce x 'string) ))) list)))))
(defun map-sequences (function sequences)
(ret (fif
(member () sequences) ()
(cons (apply function (mapfuncall #'car sequences))
(map-sequences function (mapfuncall #'cdr sequences))))))
(defun map (result-type function &rest sequences)
(ret (fif
result-type (coerce (map-sequences function sequences) result-type)
(progn (map-sequences function sequences) nil))))
(defmacro catch (tag &rest body)
`(values-list
(clet ((*thrown* :unthrown)
(*LISP-frame-result* :unevaled))
(ccatch ,tag *thrown* (csetq *LISP-frame-result* (multiple-value-list (trace-progn ,@body))))
(fif (equal *LISP-frame-result* :unevaled) (list *thrown*) *LISP-frame-result*))))
(defun make-string (size &key (initial-element #\space) element-type)
(make-string size initial-element))
(defun cl-make-hash-table (&key (test #'eql) (size 0) rehash-size rehash-threshold)
(make-hash-table size test))
(defun member (item list &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(member item list test key))
(defun member-if (fn list &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(member-if fn list test key))
(defun subsetp (list1 list &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(subsetp list1 list test key))
(defun intersection (list1 list &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(intersection list1 list test key))
(defun adjoin (item place &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(adjoin item list test key))
(defun remove (item list &key (test #'eql)(key #'identity)(start 0) end count from-end test-not (listfn #'identity))
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (csetq thefn #'reverse))
(apply listfn (remove item (apply listfn list) test key start end count)))
(defun remove-if (fn list &key (test #'eql)(key #'identity)(start 0) end count from-end test-not (listfn #'identity))
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (csetq thefn #'reverse))
(apply listfn (remove-if fn (apply listfn list) test key start end count)))
(defun remove-if-not (fn list &key (test #'eql)(key #'identity)(start 0) end count from-end test-not (listfn #'identity))
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (csetq thefn #'reverse))
(apply listfn (remove-if-not fn (apply listfn list) test key start end count)))
(defun remove-duplicates (list &key (test #'eql)(key #'identity)(start 0) end count from-end test-not (listfn #'identity))
(pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (csetq thefn #'reverse))
(apply listfn (remove-duplicates (apply listfn list) test key start end count)))
;;barely started coding
(defun make-array (dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset)(make-vector dimensions initial-element))
;;barely started coding
(defun array-dimensions (array subdim) (ret (pcase subdim (0 (length array)(t (length (nth subdim array)))))))
(defvar *complement-fns* (make-hash-table 31) "defcomplement Hashtable to lookup how things like (complement #'member) might return")
(defun complement (fn)
"If FN returns y, then (paip-complement FN) returns (not y)."
(ret (pcond
((gethash fn *complement-fns*))
(t #'(lambda (&rest pattern) (ret (cnot (apply fn pattern))))))))
(shadow-operator 'complement :CL 'CL::complement)
;;example:: (defcomplement < >=)
(defmacro defcomplement (posfn negfn)
(ret `(progn (sethash #',posfn *complement-fns* #',negfn) (sethash #',negfn *complement-fns* #',posfn))))
;;Some predicates for analyzing Lisp forms. These are used by various
;;macro expanders to optimize the results in certain common cases.
(defconst CL::simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
car-safe cdr-safe progn prog1 prog2))
(defconst CL::safe-funcs '(* / % length memq list vector vectorp
< > <= >= = error))
(defmacro defcoerce (to from &rest body)
"the body assumes bindings will be present for value vtype result-type and howto. (car howto) will yeild the original from durring defcoerce
example:: (defcoerce string t (coerce-string value))
(car howto) = > t
so that the (coerce #\a 'string ) procedure can know that vtype when character was found as a subclass of t"
(ret `(sethash ',to *coerce-methods* (acons ',from '(progn ,@body) (gethash ',to *coerce-methods*)))))
(defcoerce chew t (cconcatenate (coerce-string value) "-chew"))
;;setf-method
;;error (print (coerce "stringy" 'chew))
;;(punless (member :CYC-COMMON-LISP *features*) (FORCE-PRINT '(LOAD "common-lisp.lisp"))(shadow-push :CYC-COMMON-LISP *features*))
(defun car-safe (object) (fif (consp object) (car object)))
(defun cdr-safe (object) (fif (consp object) (cdr object)))
;;(USE-PACKAGE '(:SUBLISP :CYC) :SYSTEM)
;;(describe-package :SYSTEM)
;;(USE-PACKAGE :SYSTEM :CL)
(punless (fboundp 'defmethod)
(defmacro defmethod (name pattern &rest body)
`(defun ',name ',pattern ,@body)))
;;Check if no side effects, and executes quickly.
(defun simple-expr-p (x &optional size)
(or size (setq size 10))
(if (and (consp x) (not (memq (car x) '(quote function function*))))
(and (symbolp (car x))
(or (memq (car x) CL::simple-funcs)
(get (car x) 'side-effect-free))
(progn
(setq size (1- size))
(while (and (setq x (cdr x))
(setq size (CL::simple-expr-p (car x) size))))
(and (null x) (>= size 0) size)))
(and (> size 0) (1- size))))
(defun simple-exprs-p (xs)
(while (and xs (CL::simple-expr-p (car xs)))
(setq xs (cdr xs)))
(not xs))
;;Check if no side effects.
(defun safe-expr-p (x)
(or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
(and (symbolp (car x))
(or (memq (car x) CL::simple-funcs)
(memq (car x) CL::safe-funcs)
(get (car x) 'side-effect-free))
(progn
(while (and (setq x (cdr x)) (CL::safe-expr-p (car x))))
(null x)))))
;;Check if constant (i.e., no side effects or dependencies).
(defun const-expr-p (x)
(cond ((consp x)
(or (eq (car x) 'quote)
(and (memq (car x) '(function function*))
(or (symbolp (nth 1 x))
(and (eq (car-safe (nth 1 x)) 'CL::lambda) 'func)))))
((symbolp x) (and (memq x '(nil t)) t))
(t t)))
(defun const-exprs-p (xs)
(while (and xs (CL::const-expr-p (car xs)))
(setq xs (cdr xs)))
(not xs))
(defun const-expr-val (x)
(and (eq (CL::const-expr-p x) t) (if (consp x) (nth 1 x) x)))
(defun expr-access-order (x v)
(if (CL::const-expr-p x) v
(if (consp x)
(progn
(while (setq x (cdr x)) (setq v (CL::expr-access-order (car x) v)))
v)
(if (eq x (car v)) (cdr v) '(t)))))
;;Count number of times X refers to Y. Return nil for 0 times.
(defun expr-contains (x y)
(cond ((equal y x) 1)
((and (consp x) (not (memq (car-safe x) '(quote function function*))))
(let ((sum 0))
(while x
(setq sum (+ sum (or (CL::expr-contains (pop x) y) 0))))
(and (> sum 0) sum)))
(t nil)))
(defun expr-contains-any (x y)
(while (and y (not (CL::expr-contains x (car y)))) (pop y))
y)
;;Check whether X may depend on any of the symbols in Y.
(defun expr-depends-p (x y)
(and (not (CL::const-expr-p x))
(or (not (CL::safe-expr-p x)) (CL::expr-contains-any x y))))
;;Symbols.
;;Blocks and exits.
(defmacro block (name &rest body)
"defun a lexically-scoped block named NAME.
NAME may be any symbol. Code inside the BODY forms can call `return-from'
to jump prematurely out of the block. This differs from `catch' and `throw'
in two respects: First, the NAME is an unevaluated symbol rather than a
quoted symbol or other form; and second, NAME is lexically rather than
dynamically scoped: Only references to it within BODY will work. These
references may appear inside macro expansions, but not inside functions
called from BODY."
(if (CL::safe-expr-p (cons 'progn body)) (cons 'progn body)
(list 'CL::block-wrapper
(list* 'catch (list 'quote (intern (format nil "--CL::block-%s--" name)))
body))))
;;(defvar CL::active-block-names nil)
(put 'CL::block-wrapper 'byte-compile 'CL::byte-compile-block)
(defun byte-compile-block (CL::form)
(if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
(progn
(let* ((CL::entry (cons (nth 1 (nth 1 (nth 1 CL::form))) nil))
(CL::active-block-names (cons CL::entry CL::active-block-names))
(CL::body (byte-compile-top-level
(cons 'progn (cddr (nth 1 CL::form))))))
(if (cdr CL::entry)
(byte-compile-form (list 'catch (nth 1 (nth 1 CL::form)) CL::body))
(byte-compile-form CL::body))))
(byte-compile-form (nth 1 CL::form))))
(put 'CL::block-throw 'byte-compile 'CL::byte-compile-throw)
(defun byte-compile-throw (CL::form)
(let ((CL::found (assq (nth 1 (nth 1 CL::form)) CL::active-block-names)))
(if CL::found (setcdr CL::found t)))
(byte-compile-normal-call (cons 'throw (cdr CL::form))))
(defmacro return (&optional result)
"Return from the block named nil.
This is equivalent to `(return-from nil RESULT)'."
(list 'return-from nil result))
(defmacro return-from (name &optional result)
"Return from the block named NAME.
This jump out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
(let ((name2 (intern (format nil "--CL::block-%s--" name))))
(list 'CL::block-throw (list 'quote name2) result)))
(defvar CL::optimize-safety)
(defvar CL::optimize-speed)
;;This kludge allows macros which use CL::transform-function-property
;;to be called at compile-time.
(require
(progn
(or (fboundp 'CL::transform-function-property)
(defalias 'CL::transform-function-property
(function #'(lambda (n p f)
(list 'put (list 'quote n) (list 'quote p)(list 'function (cons 'CL::lambda f)))))))
(car (or features (setq features (list 'CL::kludge))))))
;;Initialization.
(defvar CL::old-bc-file-form nil)
(defun CL::compile-time-init for()
(run-hooks 'CL::hack-bytecomp-hook))
;;Program structure.
(defmacro defun* (name args &rest body)
"defun NAME as a function.
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(let* ((res (transform-lambda (cons args body) name))
(form (list* 'defun name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
(defmacro defmacro* (name args &rest body)
"defun NAME as a macro.
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(let* ((res (transform-lambda (cons args body) name))
(form (list* 'defmacro name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
(defmacro function* (func)
"Introduce a function.
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
(if (eq (car-safe func) 'lambda)
(let* ((res (transform-lambda (cdr func) 'CL::none))
(form (list 'function (cons 'lambda (cdr res)))))
(if (car res) (list 'progn (car res) form) form))
(list 'function func)))
(defun CL::transform-function-property (func prop form)
(let ((res (transform-lambda form func)))
(append '(progn) (cdr (cdr (car res)))
(list (list 'put (list 'quote func) (list 'quote prop)
(list 'function (cons 'lambda (cdr res))))))))
(defconst lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
(defvar CL::macro-environment nil)
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
(defun transform-lambda-unused (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(bind-defs nil) (bind-enquote nil)
(bind-inits nil) (bind-lets nil) (bind-forms nil)
(header nil) (simple-args nil))
(while (or (stringp (car body))
(memq (car-safe (car body)) '(interactive declare)))
(push (pop body) header))
(setq args (if (listp args) (copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq bind-defs (cadr (memq '&CL::defs args)))
(setq args (delq '&CL::defs (delq bind-defs args))
bind-defs (cadr bind-defs)))
(if (setq bind-enquote (memq '&CL::quote args))
(setq args (delq '&CL::quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p)))
(if p (setq args (nconc (delq (car p) (delq v args))
(list '&aux (list v 'CL::macro-environment))))))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
(not (and (eq (car args) '&optional)
(or bind-defs (consp (cadr args))))))
(push (pop args) simple-args))
(or (eq bind-block 'CL::none)
(setq body (list (list* 'block bind-block body))))
(if (null args)
(list* nil (nreverse simple-args) (nconc (nreverse header) body))
(if (memq '&optional simple-args) (push '&optional args))
(CL::do-arglist args nil (- (length simple-args) (if (memq '&optional simple-args) 1 0)))
(setq bind-lets (nreverse bind-lets))
(list* (and bind-inits (list* 'eval-when '(compile load eval) (nreverse bind-inits)))
(nconc (nreverse simple-args) (list '&rest (car (pop bind-lets))))
(nconc
(let ((hdr (nreverse header)))
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
;;orig-args can contain &CL::defs (an internal CL
;;thingy that I do not understand), so remove it.
(let ((x (memq '&CL::defs orig-args)))
(if (null x) orig-args
(delq (car x) (remq (cadr x) orig-args)))))
hdr))
(list (nconc (list 'let* bind-lets) (nreverse bind-forms) body))))) ))
(defun CL::do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
(if (or (memq args lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
(push (list args expr) bind-lets))
(setq args (copy-list args))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((save-args args)
(restarg (memq '&rest args))
(safety (if (CL::compiling-file) CL::optimize-safety 3))
(keys nil)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
(if (listp (cadr restarg))
(setq restarg (make-symbol "--CL::rest--"))
(setq restarg (cadr restarg)))
(push (list restarg expr) bind-lets)
(if (eq (car args) '&whole)
(push (list (CL::pop2 args) restarg) bind-lets))
(let ((p args))
(setq minarg restarg)
(while (and p (not (memq (car p) lambda-list-keywords)))
(or (eq p args) (setq minarg (list 'cdr minarg)))
(setq p (cdr p)))
(if (memq (car p) '(nil &aux))
(setq minarg (list '= (list 'length restarg)
(length (ldiff args p)))
exactarg (not (eq args p)))))
(while (and args (not (memq (car args) lambda-list-keywords)))
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
restarg)))
(CL::do-arglist
(pop args)
(if (or laterarg (= safety 0)) poparg
(list 'if minarg poparg
(list 'signal '(quote wrong-number-of-arguments)
(list 'list (and (not (eq bind-block 'CL::none))
(list 'quote bind-block))
(list 'length restarg)))))))
(setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
(while (and args (not (memq (car args) lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(if (cddr arg) (CL::do-arglist (nth 2 arg) (list 'and restarg t)))
(let ((def (if (cdr arg) (nth 1 arg)
(or (car bind-defs)
(nth 1 (assq (car arg) bind-defs)))))
(poparg (list 'pop restarg)))
(and def bind-enquote (setq def (list 'quote def)))
(CL::do-arglist (car arg)
(if def (list 'if restarg poparg def) poparg))
(setq num (1+ num))))))
(if (eq (car args) '&rest)
(let ((arg (CL::pop2 args)))
(if (consp arg) (CL::do-arglist arg restarg)))
(or (eq (car args) '&key) (= safety 0) exactarg
(push (list 'if restarg
(list 'signal '(quote wrong-number-of-arguments)
(list 'list
(and (not (eq bind-block 'CL::none))
(list 'quote bind-block))
(list '+ num (list 'length restarg)))))
bind-forms)))
(while (and (eq (car args) '&key) (pop args))
(while (and args (not (memq (car args) lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
(intern (format nil ":%s" (car arg)))))
(varg (if (consp (car arg)) (cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
(or (car bind-defs) (cadr (assq varg bind-defs)))))
(look (list 'memq (list 'quote karg) restarg)))
(and def bind-enquote (setq def (list 'quote def)))
(if (cddr arg)
(let* ((temp (or (nth 2 arg) (make-symbol "--CL::var--")))
(val (list 'car (list 'cdr temp))))
(CL::do-arglist temp look)
(CL::do-arglist varg
(list 'if temp
(list 'prog1 val (list 'setq temp t))
def)))
(CL::do-arglist
varg
(list 'car
(list 'cdr
(if (null def)
look
(list 'or look
(if (eq (CL::const-expr-p def) t)
(list
'quote
(list nil (CL::const-expr-val def)))
(list 'list nil def))))))))
(push karg keys)))))
(setq keys (nreverse keys))
(or (and (eq (car args) '&allow-other-keys) (pop args))
(null keys) (= safety 0)
(let* ((var (make-symbol "--CL::keys--"))
(allow '(:allow-other-keys))
(check (list
'while var
(list
'cond
(list (list 'memq (list 'car var)
(list 'quote (append keys allow)))
(list 'setq var (list 'cdr (list 'cdr var))))
(list (list 'car
(list 'cdr
(list 'memq (cons 'quote allow)
restarg)))
(list 'setq var nil))
(list t
(list
'error
(format nil "Keyword argument %%s not one of %s"
keys)
(list 'car var)))))))
(push (list 'let (list (list var restarg)) check) bind-forms)))
(while (and (eq (car args) '&aux) (pop args))
(while (and args (not (memq (car args) lambda-list-keywords)))
(if (consp (car args))
(if (and bind-enquote (cadar args))
(CL::do-arglist (caar args)
(list 'quote (cadr (pop args))))
(CL::do-arglist (caar args) (cadr (pop args))))
(CL::do-arglist (pop args) nil))))
(if args (error "Malformed argument list %s" save-args)))))
(defun CL::arglist-args (args)
(if (nlistp args) (list args)
(let ((res nil) (kind nil) arg)
(while (consp args)
(setq arg (pop args))
(if (memq arg lambda-list-keywords) (setq kind arg)
(if (eq arg '&CL::defs) (pop args)
(and (consp arg) kind (setq arg (car arg)))
(and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
(setq res (nconc res (CL::arglist-args arg))))))
(nconc res (and args (list args))))))
(defmacro destructuring-bind (args expr &rest body)
(let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
(bind-defs nil) (bind-block 'CL::none))
(CL::do-arglist (or args '(&aux)) expr)
(append '(progn) bind-inits
(list (nconc (list 'let* (nreverse bind-lets))
(nreverse bind-forms) body)))))
(defun CL::COMPILING-FILE ())
;;The `eval-when' form.
(defvar CL::not-toplevel nil)
(defmacro eval-when-ever (when &rest body)
"Control when BODY is evaluated.
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
\(fn (WHEN...) BODY...)"
(if (and (fboundp 'CL::compiling-file) (CL::compiling-file)
(not CL::not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(CL::not-toplevel t))
(if (or (memq 'load when) (memq :load-toplevel when))
(if comp (cons 'progn (mapfuncall 'CL::compile-time-too body))
(list* 'if nil nil body))
(progn (if comp (eval (cons 'progn body))) nil)))
(and (or (memq 'eval when) (memq :execute when))
(cons 'progn body))))
(defun compile-time-too (form)
(or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
(setq form (macroexpand
form (cons '(eval-when) byte-compile-macro-environment))))
(cond ((eq (car-safe form) 'progn)
(cons 'progn (mapfuncall 'CL::compile-time-too (cdr form))))
((eq (car-safe form) 'eval-when)
(let ((when (nth 1 form)))
(if (or (memq 'eval when) (memq :execute when))
(list* 'eval-when (cons 'compile when) (cddr form))
form)))
(t (eval form) form)))
(defmacro load-time-value (form &optional read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(if (CL::compiling-file)
(let* ((temp (gentemp "--CL::load-time--"))
(set (list 'set (list 'quote temp) form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
(boundp 'this-kind) (boundp 'that-one))
(fset 'byte-compile-file-form
(list 'CL::lambda '(form)
(list 'fset '(quote byte-compile-file-form)
(list 'quote
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
(print set (symbol-value 'outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
(defmacro ecase (expr &rest clauses)
"Like `case', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
(list* 'case expr (append clauses '((ecase-error-flag)))))
(defmacro typecase (expr &rest clauses)
"Evals EXPR, chooses among clauses on that value.
Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds,
typecase returns nil. A TYPE of t or `otherwise' is allowed only in the
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
(let* ((temp (if (CL::simple-expr-p expr 3) expr (make-symbol "--CL::var--")))
(type-list nil)
(body (cons
'cond
(mapfuncall
(function
#'(lambda (c)
(cons (cond ((eq (car c) 'otherwise) t)
((eq (car c) 'ecase-error-flag)
(list 'error "etypecase failed: %s, %s"
temp (list 'quote (reverse type-list))))
(t
(push (car c) type-list)
(CL::make-type-test temp (car c))))
(or (cdr c) '(nil)))))
clauses))))
(if (eq temp expr) body
(list 'let (list (list temp expr)) body))))
(defmacro etypecase (expr &rest clauses)
"Like `typecase', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
(list* 'typecase expr (append clauses '((ecase-error-flag)))))
;;The "loop" macro.
(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
(defvar loop-result) (defvar loop-result-explicit)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
((defmacro loop (&rest args)
"The Common Lisp `loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
always COND, never COND, thereis COND, collect EXPR into VAR,
append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
finally return EXPR, named NAME.
\(fn CLAUSE...)"
(if (not (memq t (mapfuncall 'symbolp (delq nil (delq t (copy-list args))))))
(list 'block nil (list* 'while t args))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
(loop-result nil) (loop-result-explicit nil)
(loop-result-var nil) (loop-finish-flag nil)
(loop-accum-var nil) (loop-accum-vars nil)
(loop-initially nil) (loop-finally nil)
(loop-map-form nil) (loop-first-flag nil)
(loop-destr-temps nil) (loop-symbol-macs nil))
(setq args (append args '(CL::end-loop)))
(while (not (eq (car args) 'CL::end-loop)) (CL::parse-loop-clause))
(if loop-finish-flag
(push `((,loop-finish-flag t)) loop-bindings))
(if loop-first-flag
(progn (push `((,loop-first-flag t)) loop-bindings)
(push `(setq ,loop-first-flag nil) loop-steps)))
(let* ((epilogue (nconc (nreverse loop-finally)
(list (or loop-result-explicit loop-result))))
(ands (CL::loop-build-ands (nreverse loop-body)))
(while-body (nconc (cadr ands) (nreverse loop-steps)))
(body (append
(nreverse loop-initially)
(list (if loop-map-form
(list 'block '--CL::finish--
(subst
(if (eq (car ands) t) while-body
(cons `(or ,(car ands)
(return-from --CL::finish--
nil))
while-body))
'--CL::map loop-map-form))
(list* 'while (car ands) while-body)))
(if loop-finish-flag
(if (equal epilogue '(nil)) (list loop-result-var)
`((if ,loop-finish-flag
(progn ,@epilogue) ,loop-result-var)))
epilogue))))
(if loop-result-var (push (list loop-result-var) loop-bindings))
(while loop-bindings
(if (cdar loop-bindings)
(setq body (list (CL::loop-let (pop loop-bindings) body t)))
(let ((lets nil))
(while (and loop-bindings
(not (cdar loop-bindings)))
(push (car (pop loop-bindings)) lets))
(setq body (list (CL::loop-let lets body nil))))))
(if loop-symbol-macs
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
(defun parse-loop-clause () ; uses args, loop-*
(let ((word (pop args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
((null args)
(error "Malformed `loop' macro"))
((eq word 'named)
(setq loop-name (pop args)))
((eq word 'initially)
(if (memq (car args) '(do doing)) (pop args))
(or (consp (car args)) (error "Syntax error on `initially' clause"))
(while (consp (car args))
(push (pop args) loop-initially)))
((eq word 'finally)
(if (eq (car args) 'return)
(setq loop-result-explicit (or (CL::pop2 args) '(quote nil)))
(if (memq (car args) '(do doing)) (pop args))
(or (consp (car args)) (error "Syntax error on `finally' clause"))
(if (and (eq (caar args) 'return) (null loop-name))
(setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
(while (consp (car args))
(push (pop args) loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
(ands nil))
(while
;;Use `gensym' rather than `make-symbol'. It's important that
;;(not (eq (symbol-name var1) (symbol-name var2))) because
;;these vars get added to the CL::macro-environment.
(let ((var (or (pop args) (gensym "--CL::var--"))))
(setq word (pop args))
(if (eq word 'being) (setq word (pop args)))
(if (memq word '(the each)) (setq word (pop args)))
(if (memq word '(buffer buffers))
(setq word 'in args (cons '(buffer-list) args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
(push word args)
(if (memq (car args) '(downto above))
(error "Must specify `from' value for downward loop"))
(let* ((down (or (eq (car args) 'downfrom)
(memq (caddr args) '(downto above))))
(excl (or (memq (car args) '(above below))
(memq (caddr args) '(above below))))
(start (and (memq (car args) '(from upfrom downfrom))
(CL::pop2 args)))
(end (and (memq (car args)
'(to upto downto above below))
(CL::pop2 args)))
(step (and (eq (car args) 'by) (CL::pop2 args)))
(end-var (and (not (CL::const-expr-p end))
(make-symbol "--CL::var--")))
(step-var (and (not (CL::const-expr-p step))
(make-symbol "--CL::var--"))))
(and step (numberp step) (<= step 0)
(error "Loop `by' value is not positive: %s" step))
(push (list var (or start 0)) loop-for-bindings)
(if end-var (push (list end-var end) loop-for-bindings))
(if step-var (push (list step-var step)
loop-for-bindings))
(if end
(push (list
(if down (if excl '> '>=) (if excl '< '<=))
var (or end-var end)) loop-body))
(push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))
((memq word '(in in-ref on))
(let* ((on (eq word 'on))
(temp (if (and on (symbolp var))
var (make-symbol "--CL::var--"))))
(push (list temp (pop args)) loop-for-bindings)
(push (list 'consp temp) loop-body)
(if (eq word 'in-ref)
(push (list var (list 'car temp)) loop-symbol-macs)
(or (eq temp var)
(progn
(push (list var nil) loop-for-bindings)
(push (list var (if on temp (list 'car temp)))
loop-for-sets))))
(push (list temp
(if (eq (car args) 'by)
(let ((step (CL::pop2 args)))
(if (and (memq (car-safe step)
'(quote function
function*))
(symbolp (nth 1 step)))
(list (nth 1 step) temp)
(list 'funcall step temp)))
(list 'cdr temp)))
loop-for-steps)))
((eq word '=)
(let* ((start (pop args))
(then (if (eq (car args) 'then) (CL::pop2 args) start)))
(push (list var nil) loop-for-bindings)
(if (or ands (eq (car args) 'and))
(progn
(push `(,var
(if ,(or loop-first-flag
(setq loop-first-flag
(make-symbol "--CL::var--")))
,start ,var))
loop-for-sets)
(push (list var then) loop-for-steps))
(push (list var
(if (eq start then) start
`(if ,(or loop-first-flag
(setq loop-first-flag
(make-symbol "--CL::var--")))
,start ,then)))
loop-for-sets))))
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--CL::vec--"))
(temp-idx (make-symbol "--CL::idx--")))
(push (list temp-vec (pop args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push (list '< (list 'setq temp-idx (list '1+ temp-idx))
(list 'length temp-vec)) loop-body)
(if (eq word 'across-ref)
(push (list var (list 'aref temp-vec temp-idx))
loop-symbol-macs)
(push (list var nil) loop-for-bindings)
(push (list var (list 'aref temp-vec temp-idx))
loop-for-sets))))
((memq word '(element elements))
(let ((ref (or (memq (car args) '(in-ref of-ref))
(and (not (memq (car args) '(in of)))
(error "Expected `of'"))))
(seq (CL::pop2 args))
(temp-seq (make-symbol "--CL::seq--"))
(temp-idx (if (eq (car args) 'using)
(if (and (= (length (cadr args)) 2)
(eq (caadr args) 'index))
(cadr (CL::pop2 args))
(error "Bad `using' clause"))
(make-symbol "--CL::idx--"))))
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-idx 0) loop-for-bindings)
(if ref
(let ((temp-len (make-symbol "--CL::len--")))
(push (list temp-len (list 'length temp-seq))
loop-for-bindings)
(push (list var (list 'elt temp-seq temp-idx))
loop-symbol-macs)
(push (list '< temp-idx temp-len) loop-body))
(push (list var nil) loop-for-bindings)
(push (list 'and temp-seq
(list 'or (list 'consp temp-seq)
(list '< temp-idx
(list 'length temp-seq))))
loop-body)
(push (list var (list 'if (list 'consp temp-seq)
(list 'pop temp-seq)
(list 'aref temp-seq temp-idx)))
loop-for-sets))
(push (list temp-idx (list '1+ temp-idx))
loop-for-steps)))
((memq word hash-types)
(or (memq (car args) '(in of)) (error "Expected `of'"))
(let* ((table (CL::pop2 args))
(other (if (eq (car args) 'using)
(if (and (= (length (cadr args)) 2)
(memq (caadr args) hash-types)
(not (eq (caadr args) word)))
(cadr (CL::pop2 args))
(error "Bad `using' clause"))
(make-symbol "--CL::var--"))))
(if (memq word '(hash-value hash-values))
(setq var (prog1 other (setq other var))))
(setq loop-map-form
`(maphash #'(lambda (,var ,other) . --CL::map) ,table))))
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
(let ((ob (and (memq (car args) '(in of)) (CL::pop2 args))))
(setq loop-map-form
`(mapatoms #'(lambda (,var) . --CL::map) ,ob))))
((memq word '(overlay overlays extent extents))
(let ((buf nil) (from nil) (to nil))
(while (memq (car args) '(in of from to))
(cond ((eq (car args) 'from) (setq from (CL::pop2 args)))
((eq (car args) 'to) (setq to (CL::pop2 args)))
(t (setq buf (CL::pop2 args)))))
(setq loop-map-form
`(CL::map-extents
#'(lambda (,var ,(make-symbol "--CL::var--"))
(progn . --CL::map) nil)
,buf ,from ,to))))
((memq word '(interval intervals))
(let ((buf nil) (prop nil) (from nil) (to nil)
(var1 (make-symbol "--CL::var1--"))
(var2 (make-symbol "--CL::var2--")))
(while (memq (car args) '(in of property from to))
(cond ((eq (car args) 'from) (setq from (CL::pop2 args)))
((eq (car args) 'to) (setq to (CL::pop2 args)))
((eq (car args) 'property)
(setq prop (CL::pop2 args)))
(t (setq buf (CL::pop2 args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var (list 'cons var1 var2)) loop-for-sets))
(setq loop-map-form
`(CL::map-intervals
#'(lambda (,var1 ,var2) . --CL::map)
,buf ,prop ,from ,to))))
((memq word key-types)
(or (memq (car args) '(in of)) (error "Expected `of'"))
(let ((map (CL::pop2 args))
(other (if (eq (car args) 'using)
(if (and (= (length (cadr args)) 2)
(memq (caadr args) key-types)
(not (eq (caadr args) word)))
(cadr (CL::pop2 args))
(error "Bad `using' clause"))
(make-symbol "--CL::var--"))))
(if (memq word '(key-binding key-bindings))
(setq var (prog1 other (setq other var))))
(setq loop-map-form
`(,(if (memq word '(key-seq key-seqs))
'CL::map-keymap-recursively 'map-keymap)
#'(lambda (,var ,other) . --CL::map) ,map))))
((memq word '(frame frames screen screens))
(let ((temp (make-symbol "--CL::var--")))
(push (list var '(selected-frame))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push (list 'prog1 (list 'not (list 'eq var temp))
(list 'or temp (list 'setq temp var)))
loop-body)
(push (list var (list 'next-frame var))
loop-for-steps)))
((memq word '(window windows))
(let ((scr (and (memq (car args) '(in of)) (CL::pop2 args)))
(temp (make-symbol "--CL::var--")))
(push (list var (if scr
(list 'frame-selected-window scr)
'(selected-window)))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push (list 'prog1 (list 'not (list 'eq var temp))
(list 'or temp (list 'setq temp var)))
loop-body)
(push (list var (list 'next-window var)) loop-for-steps)))
(t
(let ((handler (and (symbolp word)
(get word 'CL::loop-for-handler))))
(if handler
(funcall handler var)
(error "Expected a `for' preposition, found %s" word)))))
(eq (car args) 'and))
(setq ands t)
(pop args))
(if (and ands loop-for-bindings)
(push (nreverse loop-for-bindings) loop-bindings)
(setq loop-bindings (nconc (mapfuncall 'list loop-for-bindings)
loop-bindings)))
(if loop-for-sets
(push (list 'progn
(CL::loop-let (nreverse loop-for-sets) 'setq ands)
t) loop-body))
(if loop-for-steps
(push (cons (if ands 'psetq 'setq)
(apply 'append (nreverse loop-for-steps)))
loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--CL::var--")))
(push (list (list temp (pop args))) loop-bindings)
(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
((memq word '(collect collecting))
(let ((what (pop args))
(var (CL::loop-handle-accum nil 'nreverse)))
(if (eq var loop-accum-var)
(push (list 'progn (list 'push what var) t) loop-body)
(push (list 'progn
(list 'setq var (list 'nconc var (list 'list what)))
t) loop-body))))
((memq word '(nconc nconcing append appending))
(let ((what (pop args))
(var (CL::loop-handle-accum nil 'nreverse)))
(push (list 'progn
(list 'setq var
(if (eq var loop-accum-var)
(list 'nconc
(list (if (memq word '(nconc nconcing))
'nreverse 'reverse)
what)
var)
(list (if (memq word '(nconc nconcing))
'nconc 'append)
var what))) t) loop-body)))
((memq word '(concat concating))
(let ((what (pop args))
(var (CL::loop-handle-accum "")))
(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
((memq word '(vconcat vconcating))
(let ((what (pop args))
(var (CL::loop-handle-accum [])))
(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
((memq word '(sum summing))
(let ((what (pop args))
(var (CL::loop-handle-accum 0)))
(push (list 'progn (list 'incf var what) t) loop-body)))
((memq word '(count counting))
(let ((what (pop args))
(var (CL::loop-handle-accum 0)))
(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
((memq word '(minimize minimizing maximize maximizing))
(let* ((what (pop args))
(temp (if (CL::simple-expr-p what) what (make-symbol "--CL::var--")))
(var (CL::loop-handle-accum nil))
(func (intern (substring (symbol-name word) 0 3)))
(set (list 'setq var (list 'if var (list func var temp) temp))))
(push (list 'progn (if (eq temp what) set
(list 'let (list (list temp what)) set))
t) loop-body)))
((eq word 'with)
(let ((bindings nil))
(while (progn (push (list (pop args)
(and (eq (car args) '=) (CL::pop2 args)))
bindings)
(eq (car args) 'and))
(pop args))
(push (nreverse bindings) loop-bindings)))
((eq word 'while)
(push (pop args) loop-body))
((eq word 'until)
(push (list 'not (pop args)) loop-body))
((eq word 'always)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--CL::flag--")))
(push (list 'setq loop-finish-flag (pop args)) loop-body)
(setq loop-result t))
((eq word 'never)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--CL::flag--")))
(push (list 'setq loop-finish-flag (list 'not (pop args)))
loop-body)
(setq loop-result t))
((eq word 'thereis)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--CL::flag--")))
(or loop-result-var (setq loop-result-var (make-symbol "--CL::var--")))
(push (list 'setq loop-finish-flag
(list 'not (list 'setq loop-result-var (pop args))))
loop-body))
((memq word '(if when unless))
(let* ((cond (pop args))
(then (let ((loop-body nil))
(CL::parse-loop-clause)
(CL::loop-build-ands (nreverse loop-body))))
(else (let ((loop-body nil))
(if (eq (car args) 'else)
(progn (pop args) (CL::parse-loop-clause)))
(CL::loop-build-ands (nreverse loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
(if (eq (car args) 'end) (pop args))
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
(if (CL::expr-contains form 'it)
(let ((temp (make-symbol "--CL::var--")))
(push (list temp) loop-bindings)
(setq form (list* 'if (list 'setq temp cond)
(subst temp 'it form))))
(setq form (list* 'if cond form)))
(push (if simple (list 'progn form t) form) loop-body))))
((memq word '(do doing))
(let ((body nil))
(or (consp (car args)) (error "Syntax error on `do' clause"))
(while (consp (car args)) (push (pop args) body))
(push (cons 'progn (nreverse (cons t body))) loop-body)))
((eq word 'return)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--CL::var--")))
(or loop-result-var (setq loop-result-var (make-symbol "--CL::var--")))
(push (list 'setq loop-result-var (pop args)
loop-finish-flag nil) loop-body))
(t
(let ((handler (and (symbolp word) (get word 'CL::loop-handler))))
(or handler (error "Expected a loop keyword, found %s" word))
(funcall handler))))
(if (eq (car args) 'and)
(progn (pop args) (CL::parse-loop-clause)))))
(defun loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
(while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
(setq p (cdr p)))
(and par p
(progn
(setq par nil p specs)
(while p
(or (CL::const-expr-p (cadar p))
(let ((temp (make-symbol "--CL::var--")))
(push (list temp (cadar p)) temps)
(setcar (cdar p) temp)))
(setq p (cdr p)))))
(while specs
(if (and (consp (car specs)) (listp (caar specs)))
(let* ((spec (caar specs)) (nspecs nil)
(expr (cadr (pop specs)))
(temp (cdr (or (assq spec loop-destr-temps)
(car (push (cons spec (or (last spec 0)
(make-symbol "--CL::var--")))
loop-destr-temps))))))
(push (list temp expr) new)
(while (consp spec)
(push (list (pop spec)
(and expr (list (if spec 'pop 'car) temp)))
nspecs))
(setq specs (nconc (nreverse nspecs) specs)))
(push (pop specs) new)))
(if (eq body 'setq)
(let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
(if temps (list 'let* (nreverse temps) set) set))
(list* (if par 'let 'let*)
(nconc (nreverse temps) (nreverse new)) body))))
(defun loop-handle-accum (def &optional func) ; uses args, loop-*
(if (eq (car args) 'into)
(let ((var (CL::pop2 args)))
(or (memq var loop-accum-vars)
(progn (push (list (list var def)) loop-bindings)
(push var loop-accum-vars)))
var)
(or loop-accum-var
(progn
(push (list (list (setq loop-accum-var (make-symbol "--CL::var--")) def))
loop-bindings)
(setq loop-result (if func (list func loop-accum-var)
loop-accum-var))
loop-accum-var))))
(defun loop-build-ands (clauses)
(let ((ands nil)
(body nil))
(while clauses
(if (and (eq (car-safe (car clauses)) 'progn)
(eq (car (last (car clauses))) t))
(if (cdr clauses)
(setq clauses (cons (nconc (butlast (car clauses))
(if (eq (car-safe (cadr clauses))
'progn)
(cdadr clauses)
(list (cadr clauses))))
(cddr clauses)))
(setq body (cdr (butlast (pop clauses)))))
(push (pop clauses) ands)))
(setq ands (or (nreverse ands) (list t)))
(list (if (cdr ands) (cons 'and ands) (car ands))
body
(let ((full (if body
(append ands (list (cons 'progn (append body '(t)))))
ands)))
(if (cdr full) (cons 'and full) (car full))))))
;;Other iteration control structures.
(defmacro do* (steps endtest &rest body)
"The Common Lisp `do*' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(CL::expand-do-loop steps endtest body t))
(defun expand-do-loop (steps endtest body star)
(list 'block nil
(list* (if star 'let* 'let)
(mapfuncall (function #'(lambda (c)
(if (consp c) (list (car c) (nth 1 c)) c)))
steps)
(list* 'while (list 'not (car endtest))
(append body
(let ((sets (mapfuncall
(function
#'(lambda (c)
(and (consp c) (cdr (cdr c))
(list (car c) (nth 2 c)))))
steps)))
(setq sets (delq nil sets))
(and sets
(list (cons (if (or star (not (cdr sets)))
'setq 'psetq)
(apply 'append sets)))))))
(or (cdr endtest) '(nil)))))
;;Assignments.
(defmacro psetq (&rest args)
"Set SYMs to the values VALs in parallel.
This is like `setq', except that all VAL forms are evaluated (in order)
before assigning any symbols SYM to the corresponding values.
\(fn SYM VAL SYM VAL ...)"
(cons 'psetf args))
;;Binding control structures.
(defmacro progv (symbols values &rest body)
"Bind SYMBOLS to VALUES dynamically in BODY.
The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
Each symbol in the first list is bound to the corresponding value in the
second list (or made unbound if VALUES is shorter than SYMBOLS); then the
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
(list 'let '((CL::progv-save nil))
(list 'unwind-protect
(list* 'progn (list 'CL::progv-before symbols values) body)
'(CL::progv-after))))
;;This should really have some way to shadow 'byte-compile properties, etc.
(defmacro flet (bindings &rest body)
"Make temporary function definitions.
This is an analogue of `let' that operates on the function cell of FUNC
rather than its value cell. The FORMs are evaluated with the specified
function definitions in place, then the definitions are undone (the FUNCs
go back to their previous definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(list* 'letf*
(mapfuncall
(function
#'(lambda (x)
(if (or (and (fboundp (car x))
(eq (car-safe (symbol-function (car x))) 'macro))
(cdr (assq (car x) CL::macro-environment)))
(error "Use `labels', not `flet', to rebind macro names"))
(let ((func (list 'function*
(list 'CL::lambda (cadr x)
(list* 'block (car x) (cddr x))))))
(if (and (CL::compiling-file)
(boundp 'byte-compile-function-environment))
(push (cons (car x) (eval func))
byte-compile-function-environment))
(list (list 'symbol-function (list 'quote (car x))) func))))
bindings)
body))
(defmacro labels (bindings &rest body)
"Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
Unlike `flet', this macro is fully compliant with the Common Lisp standard.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(let ((vars nil) (sets nil) (CL::macro-environment CL::macro-environment))
(while bindings
;;Use `gensym' rather than `make-symbol'. It's important that
;;(not (eq (symbol-name var1) (symbol-name var2))) because these
;;vars get added to the CL::macro-environment.
(let ((var (gensym "--CL::var--")))
(push var vars)
(push (list 'function* (cons 'CL::lambda (cdar bindings))) sets)
(push var sets)
(push (list (car (pop bindings)) 'CL::lambda '(&rest CL::labels-args)
(list 'list* '(quote funcall) (list 'quote var)
'CL::labels-args))
CL::macro-environment)))
(CL::macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
CL::macro-environment)))
;;The following ought to have a better definition for use with newer
;;byte compilers.
(defmacro macrolet (bindings &rest body)
"Make temporary macro definitions.
This is like `flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
(if (cdr bindings)
(list 'macrolet
(list (car bindings)) (list* 'macrolet (cdr bindings) body))
(if (null bindings) (cons 'progn body)
(let* ((name (caar bindings))
(res (transform-lambda (cdar bindings) name)))
(eval (car res))
(CL::macroexpand-all (cons 'progn body)
(cons (list* name 'CL::lambda (cdr res))
CL::macro-environment))))))
(defmacro symbol-macrolet (bindings &rest body)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(if (cdr bindings)
(list 'symbol-macrolet
(list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
(if (null bindings) (cons 'progn body)
(CL::macroexpand-all (cons 'progn body)
(cons (list (symbol-name (caar bindings))
(cadar bindings))
CL::macro-environment)))))
(defvar CL::closure-vars nil)
(defmacro lexical-let (bindings &rest body)
"Like `let', but lexically scoped.
The main visible difference is that CL::lambdas inside BODY will create
lexical closures as in Common Lisp.
\n(fn VARLIST BODY)"
(let* ((CL::closure-vars CL::closure-vars)
(vars (mapfuncall (function
#'(lambda (x)
(or (consp x) (setq x (list x)))
(push (make-symbol (format nil "--CL::%s--" (car x)))
CL::closure-vars)
(set (car CL::closure-vars) [bad-lexical-ref])
(list (car x) (cadr x) (car CL::closure-vars))))
bindings))
(ebody
(CL::macroexpand-all
(cons 'progn body)
(nconc (mapfuncall (function #'(lambda (x)
(list (symbol-name (car x))
(list 'symbol-value (caddr x))
t))) vars)
(list '(defun . CL::define-expander))
CL::macro-environment))))
(if (not (get (car (last CL::closure-vars)) 'used))
(list 'let (mapfuncall (function #'(lambda (x)
(list (caddr x) (cadr x)))) vars)
(sublis (mapfuncall (function #'(lambda (x)
(cons (caddr x)
(list 'quote (caddr x)))))
vars)
ebody))
(list 'let (mapfuncall (function #'(lambda (x)
(list (caddr x)
(list 'make-symbol
(format nil "--%s--" (car x))))))
vars)
(apply 'append '(setf)
(mapfuncall (function
#'(lambda (x)
(list (list 'symbol-value (caddr x)) (cadr x))))
vars))
ebody))))
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that CL::lambdas inside BODY will create
lexical closures as in Common Lisp.
\n(fn VARLIST BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
(setq body (list (list* 'lexical-let (list (pop bindings)) body))))
(car body)))
(defun define-expander (func &rest rest)
(list 'progn
(list 'defalias (list 'quote func)
(list 'function (cons 'CL::lambda rest)))
(list 'quote func)))
;;Multiple values.
(defmacro multiple-value-setq (vars form)
"Collect multiple return values.
FORM must return a list; the first N elements of this list are stored in
each of the symbols SYM in turn. This is analogous to the Common Lisp
`multiple-value-setq' macro, using lists to simulate true multiple return
values. For compatibility, (values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)"
(cond ((null vars) (list 'progn form nil))
((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
(t
(let* ((temp (make-symbol "--CL::var--")) (n 0))
(list 'let (list (list temp form))
(list 'prog1 (list 'setq (pop vars) (list 'car temp))
(cons 'setq (apply 'nconc
(mapfuncall (function
#'(lambda (v)
(list v (list
'nth
(setq n (1+ n))
temp))))
vars)))))))))
;;Declarations.
(defmacro locally (&rest body) (cons 'progn body))
(defmacro the (type form) form)
(defvar CL::proclaim-history t) ; for future compilers
(defvar CL::declare-stack t) ; for future compilers
(defun do-proclaim (spec hist)
(and hist (listp CL::proclaim-history) (push spec CL::proclaim-history))
(cond ((eq (car-safe spec) 'special)
(if (boundp 'byte-compile-bound-variables)
(setq byte-compile-bound-variables
(append (cdr spec) byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
(while (setq spec (cdr spec))
(or (memq (get (car spec) 'byte-optimizer)
'(nil byte-compile-inline-expand))
(error "%s already has a byte-optimizer, can't make it inline"
(car spec)))
(put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
(if (eq (get (car spec) 'byte-optimizer)
'byte-compile-inline-expand)
(put (car spec) 'byte-optimizer nil))))
((eq (car-safe spec) 'optimize)
(let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
'((0 nil) (1 t) (2 t) (3 t))))
(safety (assq (nth 1 (assq 'safety (cdr spec)))
'((0 t) (1 t) (2 t) (3 nil)))))
(if speed (setq CL::optimize-speed (car speed)
byte-optimize (nth 1 speed)))
(if safety (setq CL::optimize-safety (car safety)
byte-compile-delete-errors (nth 1 safety)))))
((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
(if (eq byte-compile-warnings t)
(setq byte-compile-warnings byte-compile-warning-types))
(while (setq spec (cdr spec))
(if (consp (car spec))
(if (eq (cadar spec) 0)
(setq byte-compile-warnings
(delq (caar spec) byte-compile-warnings))
(setq byte-compile-warnings
(adjoin (caar spec) byte-compile-warnings)))))))
nil)
;;Process any proclamations made before CL::macs was loaded.
(defvar CL::proclaims-deferred)
(let ((p (reverse CL::proclaims-deferred)))
(while p (CL::do-proclaim (pop p) t))
(setq CL::proclaims-deferred nil))
((defmacro declare (&rest specs)
(if (CL::compiling-file)
(while specs
(if (listp CL::declare-stack) (push (car specs) CL::declare-stack))
(CL::do-proclaim (pop specs) nil)))
nil)
;;Generalized variables.
(defmacro define-setf-method (func args &rest body)
"defun a `setf' method.
This method shows how to handle `setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
going to be expanded as a macro, then the BODY forms are executed and must
return a list of five elements: a temporary-variables list, a value-forms
list, a store-variables list (of length one), a store-form, and an access-
form. See `defsetf' for a simpler way to defun most setf-methods.
\(fn NAME ARGLIST BODY...)"
(append '(eval-when (compile load eval))
(if (stringp (car body))
(list (list 'put (list 'quote func) '(quote setf-documentation)
(pop body))))
(list (CL::transform-function-property
func 'setf-method (cons args body)))))
(defalias 'define-setf-expander 'define-setf-method)
(defmacro defsetf (func arg1 &rest args))
;; (defsetf caar (x) (val) (list 'setcar (list 'car x) val))
(defmacro defsetf (func arg1 &rest args)
"(defsetf NAME FUNC): defun a `setf' method.
This macro is an easy-to-use substitute for `define-setf-method' that works
well for simple place forms. In the simple `defsetf' form, `setf's of
the form (setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:
(defsetf aref aset)
Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
Here, the above `setf' call is expanded by binding the argument forms ARGS
according to ARGLIST, binding the value form VAL to STORE, then executing
BODY, which must return a Lisp form that does the necessary `setf' operation.
Actually, ARGLIST and STORE may be bound to temporary variables which are
introduced automatically to preserve proper execution order of the arguments.
Example:
(defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
(if (listp arg1)
(let* ((largs nil) (largsr nil)
(temps nil) (tempsr nil)
(restarg nil) (rest-temps nil)
(store-var (car (prog1 (car args) (setq args (cdr args)))))
(store-temp (intern (format nil "--%s--temp--" store-var)))
(lets1 nil) (lets2 nil)
(docstr nil) (p arg1))
(if (stringp (car args))
(setq docstr (prog1 (car args) (setq args (cdr args)))))
(while (and p (not (eq (car p) '&aux)))
(if (eq (car p) '&rest)
(setq p (cdr p) restarg (car p))
(or (memq (car p) '(&optional &key &allow-other-keys))
(setq largs (cons (if (consp (car p)) (car (car p)) (car p))
largs)
temps (cons (intern (format nil "--%s--temp--" (car largs)))
temps))))
(setq p (cdr p)))
(setq largs (nreverse largs) temps (nreverse temps))
(if restarg
(setq largsr (append largs (list restarg))
rest-temps (intern (format nil "--%s--temp--" restarg))
tempsr (append temps (list rest-temps)))
(setq largsr largs tempsr temps))
(let ((p1 largs) (p2 temps))
(while p1
(setq lets1 (cons `(,(car p2)
(make-symbol ,(format nil "--CL::%s--" (car p1))))
lets1)
lets2 (cons (list (car p1) (car p2)) lets2)
p1 (cdr p1) p2 (cdr p2))))
(if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
`(define-setf-method ,func ,arg1
,@(and docstr (list docstr))
(let*
,(nreverse
(cons `(,store-temp
(make-symbol ,(format nil "--CL::%s--" store-var)))
(if restarg
`((,rest-temps
(mapfuncall (lambda (_) (make-symbol "--CL::var--"))
,restarg))
,@lets1)
lets1)))
(list ; 'values
(,(if restarg 'list* 'list) ,@tempsr)
(,(if restarg 'list* 'list) ,@largsr)
(list ,store-temp)
(let*
,(nreverse
(cons (list store-var store-temp)
lets2))
,@args)
(,(if restarg 'list* 'list)
,@(cons (list 'quote func) tempsr))))))
`(defsetf ,func (&rest args) (store)
,(let ((call `(cons ',arg1
(append args (list store)))))
(if (car args)
`(list 'progn ,call store)
call)))))
;;Some standard place types from Common Lisp.
(defalias 'aset 'set-aref)
(defsetf aref aset)
(defsetf car setcar)
(defsetf cdr setcdr)
(defsetf caar (x) (val) (list 'setcar (list 'car x) val))
(defsetf cadr (x) (val) (list 'setcar (list 'cdr x) val))
(defsetf cdar (x) (val) (list 'setcdr (list 'car x) val))
(defsetf cddr (x) (val) (list 'setcdr (list 'cdr x) val))
(defsetf elt (seq n) (store)
(list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
(list 'aset seq n store)))
(defsetf get put)
(defsetf get* (x y &optional d) (store) (list 'put x y store))
(defsetf gethash (x h &optional d) (store) (list 'puthash x store h))
(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
(defsetf subseq (seq start &optional end) (new)
(list 'progn (list 'replace seq new :start1 start :end1 end) new))
(defsetf symbol-function fset)
(defsetf symbol-value set)
(defsetf symbol-plist setplist)
;;Various car/cdr aliases. Note that `cadr' is handled specially.
(defsetf first setcar)
(defsetf second (x) (store) (list 'setcar (list 'cdr x) store))
(defsetf third (x) (store) (list 'setcar (list 'cddr x) store))
(defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store))
(defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store))
(defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store))
(defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store))
(defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store))
(defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store))
(defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store))
(defsetf rest setcdr)
;;Some more Emacs-related place types.
(defsetf buffer-file-name set-visited-file-name t)
(defsetf buffer-modified-p (&optional buf) (flag)
(list 'with-current-buffer buf
(list 'set-buffer-modified-p flag)))
(defsetf buffer-name rename-buffer t)
(defsetf buffer-string () (store)
(list 'progn '(erase-buffer) (list 'insert store)))
(defsetf buffer-substring CL::set-buffer-substring)
(defsetf current-buffer set-buffer)
(defsetf current-case-table set-case-table)
(defsetf current-column move-to-column t)
(defsetf current-global-map use-global-map t)
(defsetf current-input-mode () (store)
(list 'progn (list 'apply 'set-input-mode store) store))
(defsetf current-local-map use-local-map t)
(defsetf current-window-configuration set-window-configuration t)
(defsetf default-file-modes set-default-file-modes t)
(defsetf default-value set-default)
(defsetf documentation-property put)
(defsetf extent-data set-extent-data)
(defsetf extent-face set-extent-face)
(defsetf extent-priority set-extent-priority)
(defsetf extent-end-position (ext) (store)
(list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
store) store))
(defsetf extent-start-position (ext) (store)
(list 'progn (list 'set-extent-endpoints store
(list 'extent-end-position ext)) store))
(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
(defsetf face-background-pixmap (f &optional s) (x)
(list 'set-face-background-pixmap f x s))
(defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
(defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
(defsetf face-underline-p (f &optional s) (x)
(list 'set-face-underline-p f x s))
(defsetf file-modes set-file-modes t)
(defsetf frame-height set-screen-height t)
(defsetf frame-parameters modify-frame-parameters t)
(defsetf frame-visible-p CL::set-frame-visible-p)
(defsetf frame-width set-screen-width t)
(defsetf frame-parameter set-frame-parameter)
(defsetf getenv setenv t)
(defsetf get-register set-register)
(defsetf global-key-binding global-set-key)
(defsetf keymap-parent set-keymap-parent)
(defsetf local-key-binding local-set-key)
(defsetf mark set-mark t)
(defsetf mark-marker set-mark t)
(defsetf marker-position set-marker t)
(defsetf match-data set-match-data t)
(defsetf mouse-position (scr) (store)
(list 'set-mouse-position scr (list 'car store) (list 'cadr store)
(list 'cddr store)))
(defsetf overlay-get overlay-put)
(defsetf overlay-start (ov) (store)
(list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store))
(defsetf overlay-end (ov) (store)
(list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store))
(defsetf point goto-char)
(defsetf point-marker goto-char t)
(defsetf point-max () (store)
(list 'progn (list 'narrow-to-region '(point-min) store) store))
(defsetf point-min () (store)
(list 'progn (list 'narrow-to-region store '(point-max)) store))
(defsetf process-buffer set-process-buffer)
(defsetf process-filter set-process-filter)
(defsetf process-sentinel set-process-sentinel)
(defsetf process-get process-put)
(defsetf read-mouse-position (scr) (store)
(list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
(defsetf screen-height set-screen-height t)
(defsetf screen-width set-screen-width t)
(defsetf selected-window select-window)
(defsetf selected-screen select-screen)
(defsetf selected-frame select-frame)
(defsetf standard-case-table set-standard-case-table)
(defsetf syntax-table set-syntax-table)
(defsetf visited-file-modtime set-visited-file-modtime t)
(defsetf window-buffer set-window-buffer t)
(defsetf window-display-table set-window-display-table t)
(defsetf window-dedicated-p set-window-dedicated-p t)
(defsetf window-height () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
(defsetf window-hscroll set-window-hscroll)
(defsetf window-point set-window-point)
(defsetf window-start set-window-start)
(defsetf window-width () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store))
(defsetf x-get-cutbuffer x-store-cutbuffer t)
(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
;;More complex setf-methods.
;;These should take &environment arguments, but since full arglists aren't
;;available while compiling CL::macs, we fake it by referring to the global
;;variable CL::macro-environment directly.
(define-setf-method apply (func arg1 &rest rest)
(or (and (memq (car-safe func) '(quote function function*))
(symbolp (car-safe (cdr-safe func))))
(error "First arg to apply in setf is not (function SYM): %s" func))
(let* ((form (cons (nth 1 func) (cons arg1 rest)))
(method (get-setf-method form CL::macro-environment)))
(list (car method) (nth 1 method) (nth 2 method)
(CL::setf-make-apply (nth 3 method) (cadr func) (car method))
(CL::setf-make-apply (nth 4 method) (cadr func) (car method)))))
(defun setf-make-apply (form func temps)
(if (eq (car form) 'progn)
(list* 'progn (CL::setf-make-apply (cadr form) func temps) (cddr form))
(or (equal (last form) (last temps))
(error "%s is not suitable for use with setf-of-apply" func))
(list* 'apply (list 'quote (car form)) (cdr form))))
(define-setf-method nthcdr (n place)
(let ((method (get-setf-method place CL::macro-environment))
(n-temp (make-symbol "--CL::nthcdr-n--"))
(store-temp (make-symbol "--CL::nthcdr-store--")))
(list (cons n-temp (car method))
(cons n (nth 1 method))
(list store-temp)
(list 'let (list (list (car (nth 2 method))
(list 'CL::set-nthcdr n-temp (nth 4 method)
store-temp)))
(nth 3 method) store-temp)
(list 'nthcdr n-temp (nth 4 method)))))
(define-setf-method getf (place tag &optional def)
(let ((method (get-setf-method place CL::macro-environment))
(tag-temp (make-symbol "--CL::getf-tag--"))
(def-temp (make-symbol "--CL::getf-def--"))
(store-temp (make-symbol "--CL::getf-store--")))
(list (append (car method) (list tag-temp def-temp))
(append (nth 1 method) (list tag def))
(list store-temp)
(list 'let (list (list (car (nth 2 method))
(list 'CL::set-getf (nth 4 method)
tag-temp store-temp)))
(nth 3 method) store-temp)
(list 'getf (nth 4 method) tag-temp def-temp))))
(define-setf-method substring (place from &optional to)
(let ((method (get-setf-method place CL::macro-environment))
(from-temp (make-symbol "--CL::substring-from--"))
(to-temp (make-symbol "--CL::substring-to--"))
(store-temp (make-symbol "--CL::substring-store--")))
(list (append (car method) (list from-temp to-temp))
(append (nth 1 method) (list from to))
(list store-temp)
(list 'let (list (list (car (nth 2 method))
(list 'CL::set-substring (nth 4 method)
from-temp to-temp store-temp)))
(nth 3 method) store-temp)
(list 'substring (nth 4 method) from-temp to-temp))))
;;Getting and optimizing setf-methods.
(defun get-setf-method (place &optional env)
"Return a list of five values describing the setf-method for PLACE.
PLACE may be any Lisp form which can appear as the PLACE argument to
a macro like `setf' or `incf'."
(if (symbolp place)
(let ((temp (make-symbol "--CL::setf--")))
(list nil nil (list temp) (list 'setq place temp) place))
(or (and (symbolp (car place))
(let* ((func (car place))
(name (symbol-name func))
(method (get func 'setf-method))
(case-fold-search nil))
(or (and method
(let ((CL::macro-environment env))
(setq method (apply method (cdr place))))
(if (and (consp method) (= (length method) 5))
method
(error "Setf-method for %s returns malformed method"
func)))
(and (save-match-data
(string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name))
(get-setf-method (compiler-macroexpand place)))
(and (eq func 'edebug-after)
(get-setf-method (nth (1- (length place)) place)
env)))))
(if (eq place (setq place (macroexpand place env)))
(if (and (symbolp (car place)) (fboundp (car place))
(symbolp (symbol-function (car place))))
(get-setf-method (cons (symbol-function (car place))
(cdr place)) env)
(error "No setf-method known for %s" (car place)))
(get-setf-method place env)))))
(defun setf-do-modify (place opt-expr)
(let* ((method (get-setf-method place CL::macro-environment))
(temps (car method)) (values (nth 1 method))
(lets nil) (subs nil)
(optimize (and (not (eq opt-expr 'no-opt))
(or (and (not (eq opt-expr 'unsafe))
(CL::safe-expr-p opt-expr))
(CL::setf-simple-store-p (car (nth 2 method))
(nth 3 method)))))
(simple (and optimize (consp place) (CL::simple-exprs-p (cdr place)))))
(while values
(if (or simple (CL::const-expr-p (car values)))
(push (cons (pop temps) (pop values)) subs)
(push (list (pop temps) (pop values)) lets)))
(list (nreverse lets)
(cons (car (nth 2 method)) (sublis subs (nth 3 method)))
(sublis subs (nth 4 method)))))
(defun setf-do-store (spec val)
(let ((sym (car spec))
(form (cdr spec)))
(if (or (CL::const-expr-p val)
(and (CL::simple-expr-p val) (eq (CL::expr-contains form sym) 1))
(CL::setf-simple-store-p sym form))
(subst val sym form)
(list 'let (list (list sym val)) form))))
(defun setf-simple-store-p (sym form)
(and (consp form) (eq (CL::expr-contains form sym) 1)
(eq (nth (1- (length form)) form) sym)
(symbolp (car form)) (fboundp (car form))
(not (eq (car-safe (symbol-function (car form))) 'macro))))
;;The standard modify macros.
(defmacro setf (&rest args)
"Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
references such as (car x) or (aref x i), as well as plain symbols.
For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)"
(if (cdr (cdr args))
(let ((sets nil))
(while args (push (list 'setf (pop args) (pop args)) sets))
(cons 'progn (nreverse sets)))
(if (symbolp (car args))
(and args (cons 'setq args))
(let* ((method (CL::setf-do-modify (car args) (nth 1 args)))
(store (CL::setf-do-store (nth 1 method) (nth 1 args))))
(if (car method) (list 'let* (car method) store) store)))))
(defmacro psetf (&rest args)
"Set PLACEs to the values VALs in parallel.
This is like `setf', except that all VAL forms are evaluated (in order)
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)"
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (CL::expr-depends-p (nth 1 p) vars))
(setq simple nil))
(if (memq (car p) vars)
(error "Destination duplicated in psetf: %s" (car p)))
(push (pop p) vars)
(or p (error "Odd number of arguments to psetf"))
(pop p))
(if simple
(list 'progn (cons 'setf args) nil)
(setq args (reverse args))
(let ((expr (list 'setf (cadr args) (car args))))
(while (setq args (cddr args))
(setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr))))
(list 'progn expr nil)))))
(defun do-pop (place)
(if (CL::simple-expr-p place)
(list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
(let* ((method (CL::setf-do-modify place t))
(temp (make-symbol "--CL::pop--")))
(list 'let*
(append (car method)
(list (list temp (nth 2 method))))
(list 'prog1
(list 'car temp)
(CL::setf-do-store (nth 1 method) (list 'cdr temp)))))))
(defmacro remf (place tag)
"Remove TAG from property list PLACE.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The form returns true if TAG was found and removed, nil otherwise."
(let* ((method (CL::setf-do-modify place t))
(tag-temp (and (not (CL::const-expr-p tag)) (make-symbol "--CL::remf-tag--")))
(val-temp (and (not (CL::simple-expr-p place))
(make-symbol "--CL::remf-place--")))
(ttag (or tag-temp tag))
(tval (or val-temp (nth 2 method))))
(list 'let*
(append (car method)
(and val-temp (list (list val-temp (nth 2 method))))
(and tag-temp (list (list tag-temp tag))))
(list 'if (list 'eq ttag (list 'car tval))
(list 'progn
(CL::setf-do-store (nth 1 method) (list 'cddr tval))
t)
(list 'CL::do-remf tval ttag)))))
(defmacro shiftf (place &rest args)
"Shift left among PLACEs.
Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE... VAL)"
(cond
((null args) place)
((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
(t
(let ((method (CL::setf-do-modify place 'unsafe)))
`(let* ,(car method)
(prog1 ,(nth 2 method)
,(CL::setf-do-store (nth 1 method) `(shiftf ,@args))))))))
(defmacro rotatef (&rest args)
"Rotate left among PLACEs.
Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)"
(if (not (memq nil (mapfuncall 'symbolp args)))
(and (cdr args)
(let ((sets nil)
(first (car args)))
(while (cdr args)
(setq sets (nconc sets (list (pop args) (car args)))))
(nconc (list 'psetf) sets (list (car args) first))))
(let* ((places (reverse args))
(temp (make-symbol "--CL::rotatef--"))
(form temp))
(while (cdr places)
(let ((method (CL::setf-do-modify (pop places) 'unsafe)))
(setq form (list 'let* (car method)
(list 'prog1 (nth 2 method)
(CL::setf-do-store (nth 1 method) form))))))
(let ((method (CL::setf-do-modify (car places) 'unsafe)))
(list 'let* (append (car method) (list (list temp (nth 2 method))))
(CL::setf-do-store (nth 1 method) form) nil)))))
(defmacro letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
(list* 'let bindings body)
(let ((lets nil) (sets nil)
(unsets nil) (rev (reverse bindings)))
(while rev
(let* ((place (if (symbolp (caar rev))
(list 'symbol-value (list 'quote (caar rev)))
(caar rev)))
(value (cadar rev))
(method (CL::setf-do-modify place 'no-opt))
(save (make-symbol "--CL::letf-save--"))
(bound (and (memq (car place) '(symbol-value symbol-function))
(make-symbol "--CL::letf-bound--")))
(temp (and (not (CL::const-expr-p value)) (cdr bindings)
(make-symbol "--CL::letf-val--"))))
(setq lets (nconc (car method)
(if bound
(list (list bound
(list (if (eq (car place)
'symbol-value)
'boundp 'fboundp)
(nth 1 (nth 2 method))))
(list save (list 'and bound
(nth 2 method))))
(list (list save (nth 2 method))))
(and temp (list (list temp value)))
lets)
body (list
(list 'unwind-protect
(cons 'progn
(if (cdr (car rev))
(cons (CL::setf-do-store (nth 1 method)
(or temp value))
body)
body))
(if bound
(list 'if bound
(CL::setf-do-store (nth 1 method) save)
(list (if (eq (car place) 'symbol-value)
'makunbound 'fmakunbound)
(nth 1 (nth 2 method))))
(CL::setf-do-store (nth 1 method) save))))
rev (cdr rev))))
(list* 'let* lets body))))
(defmacro letf* (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let*', but with generalized variables (in the
sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
(if (null bindings)
(cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
(setq body (list (list* 'letf (list (pop bindings)) body))))
(car body)))
(defmacro callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
or any generalized variable allowed by `setf'.
\(fn FUNC PLACE ARGS...)"
(let* ((method (CL::setf-do-modify place (cons 'list args)))
(rargs (cons (nth 2 method) args)))
(list 'let* (car method)
(CL::setf-do-store (nth 1 method)
(if (symbolp func) (cons func rargs)
(list* 'funcall (list 'function func)
rargs))))))
(defmacro callf2 (func arg1 place &rest args)
"Set PLACE to (FUNC ARG1 PLACE ARGS...).
Like `callf', but PLACE is the second argument of FUNC, not the first.
\(fn FUNC ARG1 PLACE ARGS...)"
(if (and (CL::safe-expr-p arg1) (CL::simple-expr-p place) (symbolp func))
(list 'setf place (list* func arg1 place args))
(let* ((method (CL::setf-do-modify place (cons 'list args)))
(temp (and (not (CL::const-expr-p arg1)) (make-symbol "--CL::arg1--")))
(rargs (list* (or temp arg1) (nth 2 method) args)))
(list 'let* (append (and temp (list (list temp arg1))) (car method))
(CL::setf-do-store (nth 1 method)
(if (symbolp func) (cons func rargs)
(list* 'funcall (list 'function func)
rargs)))))))
(defmacro define-modify-macro (name arglist func &optional doc)
"defun a `setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
(if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
(let ((place (make-symbol "--CL::place--")))
(list 'defmacro* name (cons place arglist) doc
(list* (if (memq '&rest arglist) 'list* 'list)
'(quote callf) (list 'quote func) place
(CL::arglist-args arglist)))))
;;Structures.
(defmacro CL::defstruct (struct &rest descs)
"defun a struct type.
This macro cdefines a new Lisp data type called NAME, which contains data
stored in SLOTs. This cdefines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
\(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)"
(let* ((name (if (consp struct) (car struct) struct))
(opts (cdr-safe struct))
(slots nil)
(defaults nil)
(conc-name (concat (symbol-name name) "-"))
(constructor (intern (format nil "make-%s" name)))
(constrs nil)
(copier (intern (format nil "copy-%s" name)))
(predicate (intern (format nil "%s-p" name)))
(print-func nil) (print-auto nil)
(safety (if (CL::compiling-file) CL::optimize-safety 3))
(include nil)
(tag (intern (format nil "CL::struct-%s" name)))
(tag-symbol (intern (format nil "CL::struct-%s-tags" name)))
(include-descs nil)
(side-eff nil)
(type nil)
(named nil)
(forms nil)
pred-form pred-check)
(if (stringp (car descs))
(push (list 'put (list 'quote name) '(quote structure-documentation)
(pop descs)) forms))
(setq descs (cons '(CL::tag-slot)
(mapfuncall (function #'(lambda (x) (if (consp x) x (list x))))
descs)))
(while opts
(let ((opt (if (consp (car opts)) (caar opts) (car opts)))
(args (cdr-safe (pop opts))))
(cond ((eq opt :conc-name)
(if args
(setq conc-name (if (car args)
(symbol-name (car args)) ""))))
((eq opt :constructor)
(if (cdr args)
(progn
;;If this cdefines a constructor of the same name as
;;the default one, don't defun the default.
(if (eq (car args) constructor)
(setq constructor nil))
(push args constrs))
(if args (setq constructor (car args)))))
((eq opt :copier)
(if args (setq copier (car args))))
((eq opt :predicate)
(if args (setq predicate (car args))))
((eq opt :include)
(setq include (car args)
include-descs (mapfuncall (function
#'(lambda (x)
(if (consp x) x (list x))))
(cdr args))))
((eq opt :print-function)
(setq print-func (car args)))
((eq opt :type)
(setq type (car args)))
((eq opt :named)
(setq named t))
((eq opt :initial-offset)
(setq descs (nconc (make-list (car args) '(CL::skip-slot))
descs)))
(t
(error "Slot option %s unrecognized" opt)))))
(if print-func
(setq print-func (list 'progn
(list 'funcall (list 'function print-func)
'CL::x 'CL::s 'CL::n) t))
(or type (and include (not (get include 'CL::struct-print)))
(setq print-auto t
print-func (and (or (not (or include type)) (null print-func))
(list 'progn
(list 'princ (format nil "#S(%s" name)
'CL::s))))))
(if include
(let ((inc-type (get include 'CL::struct-type))
(old-descs (get include 'CL::struct-slots)))
(or inc-type (error "%s is not a struct name" include))
(and type (not (eq (car inc-type) type))
(error ":type disagrees with :include for %s" name))
(while include-descs
(setcar (memq (or (assq (caar include-descs) old-descs)
(error "No slot %s in included struct %s"
(caar include-descs) include))
old-descs)
(pop include-descs)))
(setq descs (append old-descs (delq (assq 'CL::tag-slot descs) descs))
type (car inc-type)
named (assq 'CL::tag-slot descs))
(if (cadr inc-type) (setq tag name named t))
(let ((incl include))
(while incl
(push (list 'pushnew (list 'quote tag)
(intern (format nil "CL::struct-%s-tags" incl)))
forms)
(setq incl (get incl 'CL::struct-include)))))
(if type
(progn
(or (memq type '(vector list))
(error "Invalid :type specifier: %s" type))
(if named (setq tag name)))
(setq type 'vector named 'true)))
(or named (setq descs (delq (assq 'CL::tag-slot descs) descs)))
(push (list 'defvar tag-symbol) forms)
(setq pred-form (and named
(let ((pos (- (length descs)
(length (memq (assq 'CL::tag-slot descs)
descs)))))
(if (eq type 'vector)
(list 'and '(vectorp CL::x)
(list '>= '(length CL::x) (length descs))
(list 'memq (list 'aref 'CL::x pos)
tag-symbol))
(if (= pos 0)
(list 'memq '(car-safe CL::x) tag-symbol)
(list 'and '(consp CL::x)
(list 'memq (list 'nth pos 'CL::x)
tag-symbol))))))
pred-check (and pred-form (> safety 0)
(if (and (eq (caadr pred-form) 'vectorp)
(= safety 1))
(cons 'and (cdddr pred-form)) pred-form)))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
(slot (car desc)))
(if (memq slot '(CL::tag-slot CL::skip-slot))
(progn
(push nil slots)
(push (and (eq slot 'CL::tag-slot) (list 'quote tag))
defaults))
(if (assq slot descp)
(error "Duplicate slots named %s in %s" slot name))
(let ((accessor (intern (format nil "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
(push (list*
'defsubst* accessor '(CL::x)
(append
(and pred-check
(list (list 'or pred-check
(list 'error
(format nil "%s accessing a non-%s"
accessor name)))))
(list (if (eq type 'vector) (list 'aref 'CL::x pos)
(if (= pos 0) '(car CL::x)
(list 'nth pos 'CL::x)))))) forms)
(push (cons accessor t) side-eff)
(push (list 'define-setf-method accessor '(CL::x)
(if (cadr (memq :read-only (cddr desc)))
(list 'error (format nil "%s is a read-only slot"
accessor))
(list 'CL::struct-setf-expander 'CL::x
(list 'quote name) (list 'quote accessor)
(and pred-check (list 'quote pred-check))
pos)))
forms)
(if print-auto
(nconc print-func
(list (list 'princ (format nil " %s" slot) 'CL::s)
(list 'prin1 (list accessor 'CL::x) 'CL::s)))))))
(setq pos (1+ pos))))
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and predicate pred-form
(progn (push (list 'defsubst* predicate '(CL::x)
(if (eq (car pred-form) 'and)
(append pred-form '(t))
(list 'and pred-form t))) forms)
(push (cons predicate 'error-free) side-eff)))
(and copier
(progn (push (list 'defun copier '(x) '(copy-sequence x)) forms)
(push (cons copier t) side-eff)))
(if constructor
(push (list constructor
(cons '&key (delq nil (copy-sequence slots))))
constrs))
(while constrs
(let* ((name (caar constrs))
(args (cadr (pop constrs)))
(anames (CL::arglist-args args))
(make (mapfuncall* (function #'(lambda (s d) (if (memq s anames) s d)))
slots defaults)))
(push (list 'defsubst* name
(list* '&CL::defs (list 'quote (cons nil descs)) args)
(cons type make)) forms)
(if (CL::safe-expr-p (cons 'progn (mapfuncall 'second descs)))
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" CL::s) t)))
(if print-func
(push (list 'push
(list 'function
(list 'CL::lambda '(CL::x CL::s CL::n)
(list 'and pred-form print-func)))
'custom-print-functions) forms))
(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
(push (list* 'eval-when '(compile load eval)
(list 'put (list 'quote name) '(quote CL::struct-slots)
(list 'quote descs))
(list 'put (list 'quote name) '(quote CL::struct-type)
(list 'quote (list type (eq named t))))
(list 'put (list 'quote name) '(quote CL::struct-include)
(list 'quote include))
(list 'put (list 'quote name) '(quote CL::struct-print)
print-auto)
(mapfuncall (function #'(lambda (x)
(list 'put (list 'quote (car x))
'(quote side-effect-free)
(list 'quote (cdr x)))))
side-eff))
forms)
(cons 'progn (nreverse (cons (list 'quote name) forms)))))
(defun struct-setf-expander (x name accessor pred-form pos)
(let* ((temp (make-symbol "--CL::x--")) (store (make-symbol "--CL::store--")))
(list (list temp) (list x) (list store)
(append '(progn)
(and pred-form
(list (list 'or (subst temp 'CL::x pred-form)
(list 'error
(format
"%s storing a non-%s" accessor name)))))
(list (if (eq (car (get name 'CL::struct-type)) 'vector)
(list 'aset temp pos store)
(list 'setcar
(if (<= pos 5)
(let ((xx temp))
(while (>= (setq pos (1- pos)) 0)
(setq xx (list 'cdr xx)))
xx)
(list 'nthcdr pos temp))
store))))
(list accessor temp))))
;;Types and assertions.
(defmacro deftype (name arglist &rest body)
"defun NAME as a new data type.
The type name can then be used in `typecase', `check-type', etc."
(list 'eval-when '(compile load eval)
(CL::transform-function-property
name 'CL::deftype-handler (cons (list* '&CL::defs ''('*) arglist) body))))
(defun make-type-test (val type)
(if (symbolp type)
(cond ((get type 'CL::deftype-handler)
(CL::make-type-test val (funcall (get type 'CL::deftype-handler))))
((memq type '(nil t)) type)
((eq type 'null) `(null ,val))
((eq type 'atom) `(atom ,val))
((eq type 'float) `(floatp-safe ,val))
((eq type 'real) `(numberp ,val))
((eq type 'fixnum) `(integerp ,val))
;;FIXME: Should `character' accept things like ?\C-\M-a ? -stef
((memq type '(character string-char)) `(char-valid-p ,val))
(t
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
(if (fboundp namep) (list namep val)
(list (intern (concat name "-p")) val)))))
(cond ((get (car type) 'CL::deftype-handler)
(CL::make-type-test val (apply (get (car type) 'CL::deftype-handler)
(cdr type))))
((memq (car type) '(integer float real number))
(delq t (list 'and (CL::make-type-test val (car type))
(if (memq (cadr type) '(* nil)) t
(if (consp (cadr type)) (list '> val (caadr type))
(list '>= val (cadr type))))
(if (memq (caddr type) '(* nil)) t
(if (consp (caddr type)) (list '< val (caaddr type))
(list '<= val (caddr type)))))))
((memq (car type) '(and or not))
(cons (car type)
(mapfuncall (function #'(lambda (x) (CL::make-type-test val x)))
(cdr type))))
((memq (car type) '(member member*))
(list 'and (list 'member* val (list 'quote (cdr type))) t))
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
(defun typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
(eval (CL::make-type-test 'object type)))
(defmacro check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(and (or (not (CL::compiling-file))
(< CL::optimize-speed 3) (= CL::optimize-safety 3))
(let* ((temp (if (CL::simple-expr-p form 3)
form (make-symbol "--CL::var--")))
(body (list 'or (CL::make-type-test temp type)
(list 'signal '(quote wrong-type-argument)
(list 'list (or string (list 'quote type))
temp (list 'quote form))))))
(if (eq temp form) (list 'progn body nil)
(list 'let (list (list temp form)) body nil)))))
(defmacro assert (form &optional show-args string &rest args)
"Verify that FORM returns non-nil; signal an error if not.
Second arg SHOW-ARGS means to include arguments of FORM in message.
Other args STRING and ARGS... are arguments to be passed to `error'.
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
(and (or (not (CL::compiling-file))
(< CL::optimize-speed 3) (= CL::optimize-safety 3))
(let ((sargs (and show-args (delq nil (mapfuncall
(function
#'(lambda (x)
(and (not (CL::const-expr-p x))
x))) (cdr form))))))
(list 'progn
(list 'or form
(if string
(list* 'error string (append sargs args))
(list 'signal '(quote CL::assertion-failed)
(list* 'list (list 'quote form) sargs))))
nil))))
(defmacro ignore-errors (&rest body)
"Execute BODY; if an error occurs, return nil.
Otherwise, return result of last form in BODY."
`(condition-case nil (progn ,@body) (error nil)))
;;Compiler macros.
#|
(defmacro define-compiler-macro (func args &rest body)
"defun a compiler-only macro.
This is like `defmacro', but macro expansion occurs only if the call to
FUNC is compiled (i.e., not interpreted). Compiler macros should be used
for optimizing the way calls to FUNC are compiled; the form returned by
BODY should do the same thing as a call to the normal function called
FUNC, though possibly more efficiently. Note that, like regular macros,
compiler macros are expanded repeatedly until no further expansions are
possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
(let ((p args) (res nil))
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
(list 'eval-when '(compile load eval)
(CL::transform-function-property
func 'CL::compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
(cons '--CL::whole-arg-- args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'put (list 'quote func) '(quote byte-compile)
'(quote CL::byte-compile-compiler-macro)))))
(defun compiler-macroexpand (form)
(while
(let ((func (car-safe form)) (handler nil))
(while (and (symbolp func)
(not (setq handler (get func 'CL::compiler-macro)))
(fboundp func)
(or (not (eq (car-safe (symbol-function func)) 'autoload))
(load (nth 1 (symbol-function func)))))
(setq func (symbol-function func)))
(and handler
(not (eq form (setq form (apply handler form (cdr form))))))))
form)
(defun byte-compile-compiler-macro (form)
(if (eq form (setq form (compiler-macroexpand form)))
(byte-compile-normal-call form)
(byte-compile-form form)))
(defmacro defsubst* (name args &rest body)
"defun NAME as a function.
Like `defun', except the function is automatically declared `inline',
ARGLIST allows full Common Lisp conventions, and BODY is implicitly
surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(let* ((argns (CL::arglist-args args)) (p argns)
(pbody (cons 'progn body))
(unsafe (not (CL::safe-expr-p pbody))))
(while (and p (eq (CL::expr-contains args (car p)) 1)) (pop p))
(list 'progn
(if p nil ; give up if defaults refer to earlier args
(list 'define-compiler-macro name
(if (memq '&key args)
(list* '&whole 'CL::whole '&CL::quote args)
(cons '&CL::quote args))
(list* 'CL::defsubst-expand (list 'quote argns)
(list 'quote (list* 'block name body))
(not (or unsafe (CL::expr-access-order pbody argns)))
(and (memq '&key args) 'CL::whole) unsafe argns)))
(list* 'defun* name args body))))
(defun defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (CL::safe-expr-p (cons 'progn argvs)))) whole
(if (CL::simple-exprs-p argvs) (setq simple t))
(let ((lets (delq nil
(mapfuncall* (function
#'(lambda (argn argv)
(if (or simple (CL::const-expr-p argv))
(progn (setq body (subst argv argn body))
(and unsafe (list argn argv)))
(list argn argv))))
argns argvs))))
(if lets (list 'let lets body) body))))
;;Compile-time optimizations for some functions cdefined in this package.
;;Note that cl.el arranges to force CL::macs to be loaded at compile-time,
;;mainly to make sure these macros will be present.
(put 'eql 'byte-compile nil)
(define-compiler-macro eql (&whole form a b)
(cond ((eq (CL::const-expr-p a) t)
(let ((val (CL::const-expr-val a)))
(if (and (numberp val) (not (integerp val)))
(list 'equal a b)
(list 'eq a b))))
((eq (CL::const-expr-p b) t)
(let ((val (CL::const-expr-val b)))
(if (and (numberp val) (not (integerp val)))
(list 'equal a b)
(list 'eq a b))))
((CL::simple-expr-p a 5)
(list 'if (list 'numberp a)
(list 'equal a b)
(list 'eq a b)))
((and (CL::safe-expr-p a)
(CL::simple-expr-p b 5))
(list 'if (list 'numberp b)
(list 'equal a b)
(list 'eq a b)))
(t form)))
(define-compiler-macro member* (&whole form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(CL::const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) (list 'memq a list))
((eq test 'equal) (list 'member a list))
((or (null keys) (eq test 'eql))
(if (eq (CL::const-expr-p a) t)
(list (if (floatp-safe (CL::const-expr-val a)) 'member 'memq)
a list)
(if (eq (CL::const-expr-p list) t)
(let ((p (CL::const-expr-val list)) (mb nil) (mq nil))
(if (not (cdr p))
(and p (list 'eql a (list 'quote (car p))))
(while p
(if (floatp-safe (car p)) (setq mb t)
(or (integerp (car p)) (symbolp (car p)) (setq mq t)))
(setq p (cdr p)))
(if (not mb) (list 'memq a list)
(if (not mq) (list 'member a list) form))))
form)))
(t form))))
(define-compiler-macro assoc* (&whole form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(CL::const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) (list 'assq a list))
((eq test 'equal) (list 'assoc a list))
((and (eq (CL::const-expr-p a) t) (or (null keys) (eq test 'eql)))
(if (floatp-safe (CL::const-expr-val a))
(list 'assoc a list) (list 'assq a list)))
(t form))))
(define-compiler-macro adjoin (&whole form a list &rest keys)
(if (and (CL::simple-expr-p a) (CL::simple-expr-p list)
(not (memq :key keys)))
(list 'if (list* 'member* a list keys) list (list 'cons a list))
form))
(define-compiler-macro list* (arg &rest others)
(let* ((args (reverse (cons arg others)))
(form (car args)))
(while (setq args (cdr args))
(setq form (list 'cons (car args) form)))
form))
(define-compiler-macro get* (sym prop &optional def)
(if def
(list 'getf (list 'symbol-plist sym) prop def)
(list 'get sym prop)))
(define-compiler-macro typep (&whole form val type)
(if (CL::const-expr-p type)
(let ((res (CL::make-type-test val (CL::const-expr-val type))))
(if (or (memq (CL::expr-contains res val) '(nil 1))
(CL::simple-expr-p val)) res
(let ((temp (make-symbol "--CL::var--")))
(list 'let (list (list temp val)) (subst temp val res)))))
form))
(mapc #'(lambda (y)
(put (car y) 'side-effect-free t)
(put (car y) 'byte-compile 'CL::byte-compile-compiler-macro)
(put (car y) 'CL::compiler-macro
`#'(lambda (w x)
,(if (symbolp (cadr y))
`(list ',(cadr y)
(list ',(caddr y) x))
(cons 'list (cdr y))))))
'((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
(fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
(eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
(rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
(caaar car caar) (caadr car cadr) (cadar car cdar)
(caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
(cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
(caaadr car caadr) (caadar car cadar) (caaddr car caddr)
(cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
(cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
(cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
(cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
;;Things that are inline.
(proclaim '(inline floatp-safe acons map concatenate notany notevery
CL::set-elt revappend nreconc gethash))
;;Things that are side-effect-free.
(mapc #'(lambda (x) (put x 'side-effect-free t))
'(oddp evenp signum last butlast ldiff pairlis gcd lcm
isqrt floor* ceiling* truncate* round* mod* rem* subseq
list-length get* getf))
;;Things that are side-effect-and-error-free.
(mapc #'(lambda (x) (put x 'side-effect-free 'error-free))
'(eql floatp-safe list* subst acons equalp random-state-p
copy-tree sublis))
;;(run-hooks 'CL::macs-load-hook)
;;Local variables:
;;byte-compile-warnings: (recdefine callargs free-vars unresolved obsolete noruntime)
;;End:
;;arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;CL::macs.el ends here
|#
(defmacro CL::defstruct (name &rest rest)
(let ((slots (mapfuncall #'var-of rest)))
`(defstruct (,(var-of name)) ,@slots)))
(package-export-all)
;;(USE-PACKAGE :SUBLISP :CL)
;;(USE-PACKAGE :CYC :CL)
(defun lisp () (IN-PACKAGE "CL") (load "subloopc.lisp"))
(defun lisp () (load "paip.lisp"))
;;(lisp)
;;(load "subloopc.lisp")
|#
#|
*CANONICALIZE-CLAUSE-SENTENCE-TERMS-SENSE-LAMBDA* value: NIL
*CONTAINING-SUBEXPRESSIONS-LAMBDA-TERM* value: NIL
*INVALID-LAMBDA-LIST-MESSAGE* value: Lambda list ~S of method ~S of interface ~S is not a valid lambda list.
*MERGE-DNF-LAMBDA-VAR* value: NIL
*POSITION-IF-BINARY-LAMBDA-ARG2* value: NIL
*POSITION-IF-BINARY-LAMBDA-FUNC* value: NIL
*RBP-LAMBDA-LAYER* value: NIL
*RKF-IRRELEVANT-TERM-LAMBDA-DOMAIN-MT* value: NIL
*RULE-DNF-LAMBDA-VAR* value: NIL
*TACTIC-STRATEGIC-PRODUCTIVITY-AND-COMPLETENESS-WORSE-LAMBDA-STRATEGY* value: NIL
*UIA-IRRELEVANT-PRECISION-SUGGESTION-LAMBDA-AGENDA* value: NIL
*UIA-IRRELEVANT-PRECISION-SUGGESTION-LAMBDA-MT* value: NIL
API-APPLY-LAMBDA [function] (REQ-0 REQ-1)
(API-APPLY-LAMBDA '(&rest r) '(1 2 3))
AR-PHRASE-DIVIDE-EQ-BEST-LAMBDA-SUBSTITUTE [function] (REQ-0)
CLASSES-LAMBDA-LIST-GIVEN-METHOD-DECL [function] (REQ-0)
CLASSES-VALID-LAMBDA-LIST-P [function] (REQ-0)
CONTAINING-SUBEXPRESSIONS-LAMBDA-FN [function] (REQ-0)
CYC-LAMBDA [function] (&OPTIONAL OPT-0 OPT-1 OPT-2 OPT-3 OPT-4 OPT-5)
EVAL-IN-API-USER-LAMBDA-FN? [function] (REQ-0)
FILTERED-LAMBDA-LIST unbound
function-expression [function] (REQ-0)
GENERALITY-SORT-LAMBDA [function] (REQ-0)
KBQ-FILTER-QUERY-SET-RUN-TO-QUERIES-LAMBDA [function] (REQ-0)
KBQ-FILTER-QUERY-SET-RUN-TO-QUERIES-NOT-LAMBDA [function] (REQ-0)
KCT-FILTER-TEST-SET-RUN-TO-TESTS-LAMBDA [function] (REQ-0)
KCT-FILTER-TEST-SET-RUN-TO-TESTS-NOT-LAMBDA [function] (REQ-0)
LAMBDA-EXPRESSION? [function] (REQ-0)
LAMBDA-FUNCTION-ARITY [function] (REQ-0)
LAMBDA-FUNCTION-EXPRESSION [function] (REQ-0)
LAMBDA-FUNCTION-FORMAL-ARGS [function] (REQ-0)
LAMBDA-FUNCTION-P [function] (REQ-0)
LAMBDA-LIST unbound
LAMBDA-SUBEVENT? [function] (REQ-0)
LAMBDA-SYNTAX-P [function] (REQ-0)
METHOD-LAMBDA-LIST [function] (REQ-0)
METHOD-LISTENERS-FILTERED-LAMBDA-LIST [function] (REQ-0 REQ-1)
METHODS-FILTER-OPTION-WORDS-FROM-LAMBDA-LIST [function] (REQ-0)
METHODS-LAMBDA-LIST-TO-LISTED-ARG-VALUE-EXPRESSION [function] (REQ-0)
OBJECT-METHOD-LAMBDA-LIST-METHOD [function] (REQ-0 REQ-1)
POSITION-IF-BINARY-LAMBDA [function] (REQ-0)
RBP-RB-LAYER-EXEMPT-RULE-LAMBDA? [function] (REQ-0)
REMOVAL-LAMBDA [function] (REQ-0)
RKF-IRRELEVANT-TERM-LAMBDA? [function] (REQ-0)
UIA-IRRELEVANT-PRECISION-SUGGESTION-TERM-LAMBDA? [function] (REQ-0)
_CSETF-METHOD-LAMBDA-LIST [function] (REQ-0 REQ-1)
FUNCTOR-IN-BODY-P (SYMBOL BODY)
SUBL-NON-VARIABLE-NON-KEYWORD-SYMBOL-P
SUBL-NON-VARIABLE-SYMBOL-P
SUBL-PERFORMATIVE-P
EVERY-NTH (N LIST)
ARGS-FROM-ARG-LIST
define-API-OBSOLETE
TRANSLATOR-RET-OPTIMIZE-BODY
transform-FORM-EXPANSION-FACTOR
FUNCTOR-IN-EXPRESSION-P (FUNCTOR EXPRESSION)
(csetq packname (package-name (csetq package (coerce-package *PACKAGE*))))
|#
;;
;;(import-in-all (best-symbol '(make-shadow defun shadow-defun shadow-macro defun shadow-operator)))
;;;;(make-shadow '(PROGN MAKE-HASH-TABLE LOAD STRING-DOWNCASE MAKE-STRING LOOP ) :CL)
;;(defun string-downcase (str) (string-downcase (string str)))
#|
;;(make-shadow 'defmacro :CL)
(defmacro CL::defmacro (suggest pattern &rest body)
(ret `(trace-progn (defmacro ,suggest ,@(transform-varblock suggest pattern body)))))
;;;;(make-shadow 'lambda :CL)
;;(defmacro lambda (pattern &rest body) `#'(lambda ,pattern (ret (trace-progn ,@body))))
;;(make-shadow 'defstruct :CL)
(defmacro CL::defstruct (name &rest rest)
(clet ((slots (mapfuncall #'(lambda (x) (fif (atom x) x (car x))) rest)))
`(defstruct (,name) ,@slots)))
(CL::defstruct filecomment start end src block-p)
;;(IN-PACKAGE "CL")
|#
(defvar *incompatable* '(create-instance isa all-instances comment arity load-kb
defmacro flatten assoc-equal ordered-set-difference ordered-intersection quotify permute trim-whitespace first-char
last-char ends-with starts-with string-to-number read make-string defmacro string-downcase make-hash-table
loop intersection defstruct equal member remove remove-duplicates delete-duplicates subsetp))
(defun make-package (name &rest lkeys)
(KeyLET ((use *default-package-use*) nicknames)
(FORCE-PRINT `(CL::make-package ,name ,use ,nicknames))
(ret (eval (FORCE-PRINT
`(make-package ,name
',(reverse (mapfuncall #'package-name (mapfuncall #'coerce-package use)))
',(mapfuncall #'make-keyword nicknames)))))))
#|
#> CL 'EWRT
;;(IN-PACKAGE (package-name (package-name from-package)))
(find-symbol "READ" :CL)
(csetq sym (make-symbol "PCOND"))
(import sym :CL)
(intern "PCOND" :CL)
(find-symbol "PCOND" :CL)
(intern (make-symbol "ACONS") :CL)
(find-symbol "ACONS" :CL)
(defmacro #>CL read (&rest body) (ret (cons 'read body)))
(print '(defmacro #>CL eval (&rest body) (ret (cons 'eval body))))
(defmacro read (&rest body)
(terpri)
(ret (cons 'read body)))
|#
(shadow-operator push cpush) ;;=> (defmacro push (item place) (ret (list 'cpush item place)))
(shadow-operator svref aref)
(shadow-operator vset set-aref)
(shadow-operator incf cinc)
(shadow-operator decf cdec)
;;(shadow-operator progn trace-progn)
;;(shadow-operator char-int char-code)
;;((defmacro apply (fn &rest body) (ret `(apply ,fn ,@body)))
;;(EXPORT '(CL::load like-funcall 'eval ))
#|
#+CRISPY
'(defun eval (code)
(FORCE-PRINT `(eval ,code))
(ret (eval `(trace-progn ,code))))
;;(defmacro handler-case (form &rest cases) (print (list 'handler-case form cases)) (ret `,form))
(csetq *load-verbose* t)
(csetq *load-print* t)
#+CRISPY
(defun load (filespec &rest lkeys)
(KeyLet (verbose print if-does-not-exist external-format)
(clet ((*standard-input* (OPEN-TEXT filespec :input)))
(cdo () ()
(clet ((expr (read *standard-input* nil :EOF)))
(pwhen (equal expr :EOF)
(close *standard-input*)
(ret T))
(CL::eval expr))))))
'(defmacro defstub (feat symb &optional default) `(defmacro ,symb (&rest body) (format t "~s~%" (cons ',feat (cons ',symb body))) ,default))
|#
#|
'(defmacro go (label)
(let ((name (label-to-functionname label)))
`(throw ,name #',name)))
'(defmacro tagbody (&body body)
"The emulation of tagbody/go by catch/throw is considerably less obvious than the emulation of block/return-from.
This is because tagbody defines a number of different labels rather than a single block name, and because the parsing of the
tagbody body is considerably more complicated. The various segments of the tagbody are emulated by a labels nest of mutually
recursive functions, which are forced to all execute at the correct dynamic depth by means of a
'trampoline. If the implementation implements the 'tail recursion' optimization for functions
which have no arguments and return no values, and if the simpler cases of go's are optimized away, then this emulation can be quite efficient."
(let* ((init-tag (gensym)) (go-tag (gensym)) (return-tag (gensym))
(functions
(mapcon
#'(lambda (seq &aux (label (car seq) (s (cdr seq)))
(when (atom label)
(let ((p (position-if #'atom s)))
`((,(label-to-functionname label) ()
,@(subseq s 0 (or p (length s)))
,(if p `(,(label-to-functionname (elt s p)))
`(throw ,return-tag 'nil)))))))
`(,init-tag ,@body))))
`(let* ((,go-tag (list nil)) (,return-tag (list nil))
,@(mapfuncall #'(lambda (f) `(,(car f) ,go-tag)) functions))
(catch ,return-tag
(labels ,functions
(let ((nxt-label #',(caar functions)))
(loop (csetq nxt-label (catch ,go-tag (funcall nxt-label)))))))))))
(defmacro labels (fns &body forms)
"CIRCULAR ENVIRONMENTS OF 'LABELS EMULATED BY 'FLET AND 'SETQ: It is generally believed that the circular environments of labels cannot be
obtained by means of flet. This is incorrect, as the following emulation (reminiscent of Scheme) shows.
With a more sophisticated macro-expansion, this emulation can be optimized into production-quality code."
(let* ((fnames (mapfuncall #'car fns))
(nfnames (mapfuncall #'(lambda (ignore) (gensym)) fnames))
(nfbodies (mapfuncall #'(lambda (f) `#'(lambda ,@(cdr f))) fns)))
`(let ,(mapfuncall #'(lambda (nf) `(,nf #'(lambda () ()))) nfnames)
(flet ,(mapfuncall #'(lambda (f nf) `(,f (&rest a) (apply ,nf a)))
fnames nfnames)
(flet ,fns
(progn ,@(mapfuncall #'(lambda (f nf) `(csetq ,nf #',f))
fnames nfnames))
,@forms)))))
|#
;;(defmacro loop (&rest body) (ret `(loop ,@body)))
(defun make-string (size &rest lkeys)
(clet (element-type initial-element initial-contents)
(init-keyval initial-element #\space)
(ret (make-string size initial-element))))
;;barely started coding
(defun make-array (dimensions &rest lkeys)
(clet (element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset)
(init-keyval initial-element)
(ret (make-vector dimensions initial-element))))
;;barely started coding
(defun array-dimensions (array subdim)
(ret (pcase
subdim
(0 (length array)
(t (length (nth subdim array)))))))
#|
Function MAP-INTO (still writing also require the array stuff way below)
Syntax::
map-into result-sequence function &rest sequences => result-sequence
Arguments and Values::
result-sequence--a proper sequence.
function--a designator for a function of as many arguments as there are sequences.
sequence--a proper sequence.
Description::
Destructively modifies result-sequence to contain the results of applying function to each element in the argument sequences in turn.
Examples::
(setq a (list 1 2 3 4) b (list 10 10 10 10)) => (10 10 10 10)
(map-into a #'+ a b) => (11 12 13 14)
a => (11 12 13 14)
b => (10 10 10 10)
(setq k '(one two three)) => (ONE TWO THREE)
(map-into a #'cons k a) => ((ONE . 11) (TWO . 12) (THREE . 13) 14)
(map-into a #'gensym) => (#::G9090 #::G9091 #::G9092 #::G9093)
a => (#::G9090 #::G9091 #::G9092 #::G9093)
(defun map-into (result-sequence function &rest sequences)
"Destructively set elements of RESULT-SEQUENCE to the results
of applying FUNCTION to respective elements of SEQUENCES."
(clet ((arglist (make-list (length sequences)))
(n (fif (listp result-sequence)
most-positive-fixnum
(array-dimension result-sequence 0))))
;;arglist is made into a list of pattern for each call
;;n is the length of the longest vector
(pwhen sequences
(csetf n (min n (CL::loop for seq in sequencesminimize (length seq)))))
;;shadow-defun :CL some shared functions::
(clet
((*do-one-call*
#'(lambda (i)
(ret (cdolist (seq sequences)
(cdolist (arg arglist)
(cdo (fif (listp (first seq))
(csetf (first arg)
(pop (first seq)))
(csetf (first arg)
(aref (first seq) i))))))))
(apply function arglist))
(*do-result*
#'(lambda (i)
(ret (fif (cand (vectorp result-sequence)
(array-has-fill-pointer-p result-sequence))
(csetf (fill-pointer result-sequence)
(max i (fill-pointer result-sequence))))))))
;;(declare (inline *do-one-call*))
;;Decide if the result is a list or vector,
;;and CL::loop through each element
(fif (listp result-sequence)
(CL::loop for i from 0 to (- n 1)
for r on result-sequence
do (csetf (first r)
(*do-one-call* i))
finally (*do-result* i))
(CL::loop for i from 0 to (- n 1)
do (csetf (aref result-sequence i)
(*do-one-call* i))
finally (*do-result* i))))
result-sequence))
|#
(defvar *complement-fns* (make-hash-table 31) "defcomplement Hashtable to lookup how things like (complement #'member) might return")
(defun complement (fn)
"If FN returns y, then (paip-complement FN) returns (not y)."
(ret (pcond
((gethash fn *complement-fns*))
(t #'(lambda (&rest pattern) (ret (cnot (apply fn pattern))))))))
;;example:: (defcomplement < >=)
(defmacro defcomplement (posfn negfn)
(ret `(progn (sethash #',posfn *complement-fns* #',negfn) (sethash #',negfn *complement-fns* #',posfn))))
;;emits
;;;;;;;;
(defun MEMBER (ITEM LIST &REST LKEYS)
(ret
(trace-progn
(CLET (TEST KEY TEST-NOT)
(init-keyval KEY (FUNCTION IDENTITY)) (init-keyval TEST (FUNCTION EQL))
(pWHEN TEST-NOT (SETQ TEST (FUNCTION (LAMBDA (X Y) (ret (CNOT (FUNCALL TEST-NOT X Y)))))))
(MEMBER ITEM LIST TEST KEY)))))
(defun intersection (list-1 list-2 &rest lkeys)
(trace-progn 'CL::intersection (list-1 list-2 '&rest lkeys)
(clet (test key test-not)
(init-keyval test)(init-keyval key)(init-keyval test-not)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(ret (intersection list-1 list-2 test key )))))
(defun remove (item list &rest lkeys )
;;(FORCE-PRINT `(CL::remove ,item ,list &rest ,lkeys))
(clet (test from-end test-not start end count key)
(init-keyval test #'eql)(init-keyval key #'identity)(init-keyval test-not)(init-keyval from-end)(init-keyval start 0)(init-keyval end)(init-keyval count)
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (ret (reverse (remove item (reverse list) test key start end count))))
(ret (remove item list test key start end count))))
(defun remove-duplicates (list &rest lkeys)
(trace-progn 'CL::remove-duplicates (list '&rest lkeys) ())
(clet (test from-end test-not start end count key)
(init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(funless start (csetq start 0))
(pwhen from-end (ret (reverse (remove-duplicates (reverse list) test key start end))))
(ret (remove-duplicates list test key start end))))
(defun delete-duplicates (list &rest lkeys)
(trace-progn 'CL::delete-duplicates (list '&rest lkeys)
(clet (test from-end test-not start end count key)
(init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(funless start (csetq start 0))
(pwhen from-end (ret (reverse (delete-duplicates (reverse list) test key start end))))
(ret (delete-duplicates list test key start end)))))
(defun subsetp (list list2 &rest lkeys)
(trace-progn 'CL::subsetp (list list2 '&rest lkeys)
(clet (test key test-not)
(init-keyval test)(init-keyval key)(init-keyval test-not)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(ret (subsetp list list2 test key)))))
;;(USE-PACKAGE :CL :CYC #'better-symbol)
;;(IN-PACKAGE "SYSTEM")
;;(import-in-all '(defun shadow-macro defun shadow-operator) :CL :CYC)
;;(import-in-all ;;(make-shadow 'defun :CL) :CYC)
;;
;;(make-shadow '(PROGN MAKE-HASH-TABLE LOAD STRING-DOWNCASE MAKE-STRING LOOP ) :CL)
(defun string-downcase (str) (string-downcase (string str)))
;;(make-shadow 'defstruct :CL)
(defmacro CL::defstruct (name &rest rest)
(clet ((slots (mapfuncall #'(lambda (x) (fif (atom x) x (car x))) rest)))
`(defstruct (,name) ,@slots)))
'(CL::defstruct filecomment start end src block-p)
;;(IN-PACKAGE "CL")
;;(make-shadow 'make-package :CL)
(defun make-package (name &rest lkeys)
(KeyLET ((use *default-package-use*) nicknames)
(FORCE-PRINT `(CL::make-package ,name ,use ,nicknames))
(ret (eval (FORCE-PRINT
`(make-package ,name
',(reverse (mapfuncall #'package-name (mapfuncall #'coerce-package use)))
',(mapfuncall #'make-keyword nicknames)))))))
;;(EXPORT 'CL::typep :cl)
(shadow-operator push cpush) ;;=> (defmacro push (item place) (ret (list 'cpush item place)))
(shadow-operator svref aref)
(shadow-operator vset set-aref)
(shadow-operator incf cinc)
(shadow-operator decf cdec)
;;(shadow-operator progn trace-progn)
;;(shadow-operator char-int char-code)
(defmacro defstub (feat symb &optional default) `(defmacro ,symb (&rest body) (format t "~s~%" (cons ',feat (cons ',symb body))) ,default))
#|
;;barely started coding
(defun array-dimensions (array subdim)
(ret (pcase
subdim
(0 (length array)
(t (length (nth subdim array)))))))
;;CLtL2 and ANSI CL Compatibility
(defmacro loop (&rest exps)
;;"supports both ansi and simple loop. warning:: not every loop keyword is supported."
(format t "~%~s~%" `(loop ,@exps))(FORCE-output)
(punless (member-if #'symbolp exps) (ret `(loop ,@exps)))
(pcase (car exps)
((until while) (ret exps))
(for ;;(CL::loop-for (cdr exps)))
(break "CL::loop-for"))
(repeat (break "CL::loop-repeat"))
(otherwise (ret `(loop ,@exps))))
'(defmacro loop-for (var from-in start/list &rest exps)
(pcase
from-in
(from (CL::loop-for-from var start/list
))))
|#
(defmacro _setf (place value)
(csetq value (eval `(trace-progn value)))
(with-error-handler
#'(lambda () (ret value))
(ret (csetf place value)))
(pwhen (consp place)
(clet ((object (cadr place))(type (type-of object))(slot (car place))(args (cddr place))(slotname (string slot)))
(csetq slotname (get-type-slot-args type slot args))
(csetq value (eval `(,slotname ,object ,@(append args (list value)))))))
(ret place))
(defmacro _getf (place value)
(csetq value (eval `(trace-progn value)))
(with-error-handler
#'(lambda () (ret place))
(ret (aref place value)))
(pwhen (consp place)
(clet ((object (cadr place))(type (type-of object))(slot (car place))(args (cddr place))(slotname (string slot)))
(csetq slotname (get-type-slot-args type slot args '("PUT" "GET-" "GET" "REF-" "REF")))
(csetq value (eval `(,slotname ,object ,@args)))))
(ret place))
(defun get-type-slot-args (type slot args &optional trylist)
(clet ((slotname (string slot))(typename (string slot)))
(ret (member-if #'(lambda (header)
(clet ((name (cconcatenate header slotname))(namef (find-symbol name))
tname (cconcatenate header slotname (typename type) ))(tnamef (find-symbol tname)))
(pwhen (fboundp tnamef) (ret tnamef))
(pwhen (fboundp namef) (ret namef))))
(append try '("_CSETF-" "SET-" "PUT-" "SET" )))))
;;(CL::defun FORCE-PRINT (stuff) (print stuff) (FORCE-output) stuff)
(FORCE-PRINT "this is not really cl!")
;;(macroexpand '(defun FORCE-PRINT (stuff) (print stuff) (FORCE-output)stuff))
;;(macroexpand '(trace-progn 'MYPRINT (STUFF) (PRINT STUFF) (FORCE-OUTPUT) STUFF))
;;(macroexpand '(trace-progn (PRINT STUFF) (FORCE-OUTPUT) STUFF))
(defun structure-slot (object slot)
(ret (pcond
((structurep object) (_structure-slot object slot)))))
(defun set-structure-slot (object slot value)
(ret (pcond
((structurep object) (_set-structure-slot object slot value)))))
(defvar *complement-fns* (make-hash-table 31) "defcomplement Hashtable to lookup how things like (complement #'member) might return")
(defun complement (fn)
"If FN returns y, then (paip-complement FN) returns (not y)."
(ret (pcond
((gethash fn *complement-fns*))
(t #'(lambda (&rest pattern) (ret (cnot (apply fn pattern))))))))
;;example:: (defcomplement < >=)
(defmacro defcomplement (posfn negfn)
(ret `(progn (sethash #',posfn *complement-fns* #',negfn) (sethash #',negfn *complement-fns* #',posfn))))
#|
;;emits
;;;;;;;;
(defun MEMBER (ITEM LIST &REST LKEYS)
(ret
(trace-progn
(CLET (TEST KEY TEST-NOT)
(init-keyval KEY (FUNCTION IDENTITY)) (init-keyval TEST (FUNCTION EQL))
(pWHEN TEST-NOT (SETQ TEST (FUNCTION (LAMBDA (X Y) (ret (CNOT (FUNCALL TEST-NOT X Y)))))))
(MEMBER ITEM LIST TEST KEY)))))
'(print (transform-block '
(defun intersection (list-1 list-2 &key (test #'eql)(key #'identity) test-not)
(pwhen test-not (setq test #'(lambda (x y)(not (funcall test-not x y)))))
(intersection list-1 list-2 test key))))
(defun intersection (list-1 list-2 &rest lkeys)
(trace-progn 'CL::intersection (list-1 list-2 '&rest lkeys)
(clet (test key test-not)
(init-keyval test)(init-keyval key)(init-keyval test-not)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(ret (intersection list-1 list-2 test key )))))
(defun remove (item list &rest lkeys )
;;(FORCE-PRINT `(CL::remove ,item ,list &rest ,lkeys))
(clet (test from-end test-not start end count key)
(init-keyval test #'eql)(init-keyval key #'identity)(init-keyval test-not)(init-keyval from-end)(init-keyval start 0)(init-keyval end)(init-keyval count)
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(pwhen from-end (ret (reverse (remove item (reverse list) test key start end count))))
(ret (remove item list test key start end count))))
(defun remove-duplicates (list &rest lkeys)
(trace-progn 'CL::remove-duplicates (list '&rest lkeys) ())
(clet (test from-end test-not start end count key)
(init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(funless start (csetq start 0))
(pwhen from-end (ret (reverse (remove-duplicates (reverse list) test key start end))))
(ret (remove-duplicates list test key start end))))
(defun delete-duplicates (list &rest lkeys)
(trace-progn 'CL::delete-duplicates (list '&rest lkeys)
(clet (test from-end test-not start end count key)
(init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(funless start (csetq start 0))
(pwhen from-end (ret (reverse (delete-duplicates (reverse list) test key start end))))
(ret (delete-duplicates list test key start end)))))
(defun subsetp (list list2 &rest lkeys)
(trace-progn 'CL::subsetp (list list2 '&rest lkeys)
(clet (test key test-not)
(init-keyval test)(init-keyval key)(init-keyval test-not)
(funless key (csetq key #'identity))
(funless test (csetq test #'eql))
(pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
(ret (subsetp list list2 test key)))))
|#
;;(USE-PACKAGE :CL :CYC #'better-symbol)
;;Saved into a file called common_lisp.lisp = nargs 2))
(let ((place (car places-and-newvalue)))
(multiple-value-bind (temps vars newvals setter getter)
(get-setf-expansion place env)
`(let (,@(mapfuncall #'list temps vars))
(multiple-value-prog1 ,getter
(multiple-value-bind ,newvals
,(if (= nargs 2)
(cadr places-and-newvalue)
`(shiftf ,@(cdr places-and-newvalue)))
,setter)))))))
(defmacro rotatef (&rest places &environment env)
(if (< (length places) 2)
nil
(multiple-value-bind (temps vars newvals setter getter)
(get-setf-expansion (car places) env)
`(let (,@(mapfuncall #'list temps vars))
(multiple-value-bind ,newvals (shiftf ,@(cdr places) ,getter)
,setter)
nil))))
|#
(defmacro catch (tag &body body)
(ret
`(apply #'values
(let ((*thrown* :UNTHROWN) (*result* :UNEVALED))
;;(print (list 'eval (cons 'catch (cons ',tag ',body))))(terpri)
(ccatch ,tag *thrown* (setq *result* (multiple-value-list (progn ,@body))))
(cond
((equal *result* :UNEVALED) (list *thrown*))
(t *result*))))))
;;(defun coerce (value result-type) (ret value))
;;are hashtables supposed ot be coercable back and forth from alists?
(defun coerce (value result-type)
(clet ((len value)(vtype (type-of value))(cltype result-type))
(pwhen (equal result-type vtype) (ret value))
(unless (cand (consp cltype) (setq len (second cltype)) (setq cltype (car cltype)))
(if (consp value) (setq len (length value))))
;; (print (list 'coerce value result-type cltype len))
(case cltype
('t (ret value))
('sequence
(if (sequencep value) (ret (copy-seq value)) (setq value (write-to-string value)))
(setq cltype (make-vector len))
(do ((idx 0 (+ 1 idx))) ((= idx len) (ret cltype )) (set-aref cltype idx (elt value idx))))
('character
(cond
((characterp value) (ret value))
((numberp value) (ret (code-char value)))
((stringp value) (ret (char value 0)))
(t (ret (char (coerce value 'string ) 0)))))
('number
(cond
((numberp value) (ret value))
((characterp value) (ret (char-code value)))
((stringp value) (ret (string-to-number value)))
;;not like CL
(t (ret (string-to-number (write-to-string value))))))
('integer
(ret (round (coerce value 'number))))
('fixnum
(ret (round (coerce value 'number))))
('float
(ret (float (coerce value 'number))))
('real
(ret (float (coerce value 'number))))
('flonum
(ret (float (coerce value 'number))))
('string
(cond
((stringp value) (ret value))
((characterp value) (ret (make-string 1 value)))
((sequencep value) (setq cltype (make-string len))
(do ((idx 0 (+ 1 idx))) ((= idx len) (ret cltype )) (set-aref cltype idx (coerce (elt value idx) 'character))))
(t (ret (write-to-string value)))))
('list
(cond
((listp value) (ret list))
((sequencep value)
(setq cltype nil)
(do ((idx len (- idx 1))) ((= idx 0) (ret cltype )) (setq cltype (cons (elt value idx) cltype))))
(t
(setq cltype nil)
(setq value (write-to-string value))
(do ((idx len (- idx 1))) ((= idx 0) (ret cltype )) (setq cltype (cons (elt value idx) cltype))))))
('cons
(cond
((listp value) (ret list))
((sequencep value)
(setq cltype nil)
(do ((idx len (- idx 1))) ((= idx 0) (ret cltype )) (setq cltype (cons (elt value idx) cltype))))
(t
(setq cltype nil)
(setq value (write-to-string value))
(do ((idx len (- idx 1))) ((= idx 0) (ret cltype )) (setq cltype (cons (elt value idx) cltype))))))
;;not finished
('keypair
(cond
((atom value) (ret list value))
(t (ret (coerce value 'cons)))))
;;not finished
('alist
;;(if (hash-table-p value) (ret value))
(setq cltype (setq cltype nil))
(if (sequencep value) t (setq value (coerce value 'sequence)))
(do ((idx 0 (+ 1 idx))) ((= idx len) (ret cltype))
(setq result-type (coerce (elt value idx) 'cons))
(setq cltype (acons (car result-type) (cdr result-type) cltype)))
(ret cltype))
;;not finished
('hash-table
(if (hash-table-p value) (ret value))
(setq cltype (make-hash-table len))
(if (sequencep value) t (setq value (coerce value 'sequence)))
(do ((idx 0 (+ 1 idx))) ((= idx len) (ret cltype))
(print (list 'coerce value result-type cltype len (elt value idx)))
(setq result-type (coerce (elt value idx) 'keypair))
(sethash (car result-type) cltype (cdr result-type))))
;;not like CL
(otherwise (ret value)))
(throw :coerce (list value result-type)))
(ret value))
;;(load "sublisp-cl.lisp")
#|
(defun eval-remote (server &rest remote) (print remote))
;;
;; (load "common_lisp.lisp")(macroexpand '(defstub :COMMON-LISP DEFPACKAGE))
(defun defstub (pack symb &rest body)
;; (clet ((symb `,symbn))
(let ((sname (if (symbolp symb) (symbol-name symb) (if (stringp symb) symb "")))
(fpack (if (packagep pack) pack (find-package pack)))
(fsym (if fpack (find-symbol sname fpack) (find-symbol sname))))
(when (and(symbolp symb)(fboundp symb)) (ret `(symbol-function ',symb)))
(when (and(symbolp fsym)(fboundp fsym)) (ret `(symbol-function ',fsym)))
(when (and(symbolp fsym)(fboundp fsym)(member fpack *packages-local*)) (ret `(symbol-function ',fsym)))
(unless (symbolp fsym)(setq fsym symb))
(unless (symbolp fsym)(setq fsym (intern sname)))
(unless fpack (setq fpack (symbol-package fsym)))
(setq sname (concat (package-name fpack) "::" sname))
(ret
(print `(eval
',(print (if body
;;(list 'defmacro fsym (list 'quote (car body))(list 'ret (list 'BQ-LIST* (cons '(quote eval-remote) (cons (list 'quote sname) (cdr body))))))
`(defmacro ,fsym ,(car body) (ret `(eval-remote ,,sname ,,@(cdr body))))
(list 'defmacro fsym '(&rest args)(list 'ret (list 'BQ-LIST* '(quote eval-remote) (list 'quote sname) 'args))))))))))
;;(defun do-server4005 (in-stream out-stream)(print (read in-stream) out-stream))
(defstub :common-lisp 'defpackage)
;;We will show that only one of the three non-local exit mechanisms block/return-from, tagbody/go, catch/throw is required to be primitive, by showing how to emulate any two in terms of the third.[4] We first emulate block/return-from in terms of catch/throw. We map the block name into the name of a lexical variable which will hold the unique tag which distinguishes this dynamical block from any other. If trivial return-from's are optimized away, then this emulation can be quite efficient.
(defmacro return-from-no (bname exp)
"BLOCK/RETURN-FROM EMULATED BY CATCH/THROW"
(let ((tagname (block-to-tagname bname)))
`(throw ,tagname ,exp)))
(defmacro block-no (bname &body forms)
"BLOCK/RETURN-FROM EMULATED BY CATCH/THROW"
(let ((tagname (block-to-tagname bname)))
`(let ((,tagname (list nil))) ; Unique cons cell used as catch tag.
(catch ,tagname (progn ,@forms)))))
;;dont know if this is correct
(defmacro return (body) (ret `(ret ,body)))
(defconstant *unbound-value* (list nil))
(defun msymbol-value (var)
(if (boundp var) (symbol-value var) *unbound-value*))
(defun mset (var val)
(if (eq val *unbound-value*) (makunbound var) (set var val)))
(defmacro progv (syms vals &body forms)
(let* ((vsyms (gensym)) (vvals (gensym)) (vovals (gensym)))
`(let* ((,vsyms ,syms)
(,vvals ,vals)
(,vovals ,(mapfuncall #'msymbol-value ,vsyms)))
(unwind-protect
(progn (mapc #'mset ,vsyms ,vvals)
(mapc #'makunbound (subseq ,vsyms (min (length ,vsyms) (length ,vvals))))
,@forms )
(mapc #'mset ,vsyms ,vovals)))))
;;EMULATE "THE" USING "LET" AND "DECLARE"
;;The emulation of the the special form emphasizes the fact that there is a run-time type test which must be passed in order for the program to proceed. Of course, a clever compiler can eliminate the run-time test if it can prove that it will always succeed--e.g., the gcd function always returns an integer if it returns at all.
(defmacro the (typ exp)
(if (and (consp typ) (eq (car typ) 'values))
(let ((vals (gensym)))
`(let ((,vals (multiple-value-list ,exp)))
(assert (= (length ,vals) ,(length (cdr typ))))
,@(mapfuncall #'(lambda (typ i) `(assert (typep (elt ,vals ,i) ',typ)))
(cdr typ) (iota-list (length (cdr typ))))
(values-list ,vals)))
(let ((val (gensym)))
`(let ((,val ,exp))
(assert (typep ,val ',typ))
(let ((,val ,val)) (declare (type ,typ ,val))
,val)))))
(defmacro go (label)
"TAGBODY/GO EMULATED BY CATCH/THROW"
(let ((name (label-to-functionname label)))
`(throw ,name #',name)))
(defmacro tagbody-no (&body body)
"TAGBODY/GO EMULATED BY CATCH/THROW"
(let* ((init-tag (gensym)) (go-tag (gensym)) (return-tag (gensym))
(functions
(mapcon
#'(lambda (seq &aux (label (car seq) (s (cdr seq)))
(when (atom label)
(let ((p (position-if #'atom s)))
`((,(label-to-functionname label) ()
,@(subseq s 0 (or p (length s)))
,(if p `(,(label-to-functionname (elt s p)))
`(throw ,return-tag 'nil)))))))
`(,init-tag ,@body))))
`(let* ((,go-tag (list nil)) (,return-tag (list nil))
,@(mapfuncall #'(lambda (f) `(,(car f) ,go-tag)) functions))
(catch ,return-tag
(labels ,functions
(let ((nxt-label #',(caar functions)))
(loop (setq nxt-label (catch ,go-tag (funcall nxt-label)))))))))))
(FORCE-PRINT ";; The emulation of tagbody/go by catch/throw is considerably less obvious than the emulation of block/return-from.
This is because tagbody defines a number of different labels rather than a single block name, and because the parsing of the
tagbody body is considerably more complicated. The various segments of the tagbody are emulated by a labels nest of mutually
recursive functions, which are forced to all execute at the correct dynamic depth by means of a
'trampoline. If the implementation implements the 'tail recursion' optimization for functions
which have no arguments and return no values, and if the simpler cases of go's are optimized away, then this emulation can be quite efficient."
)
(defmacro labels (fns &body forms)
"CIRCULAR ENVIRONMENTS OF 'LABELS EMULATED BY 'FLET AND 'SETQ: It is generally believed that the circular environments of labels cannot be
obtained by means of flet. This is incorrect, as the following emulation (reminiscent of Scheme) shows.
With a more sophisticated macro-expansion, this emulation can be optimized into production-quality code."
(let* ((fnames (mapfuncall #'car fns))
(nfnames (mapfuncall #'(lambda (ignore) (gensym)) fnames))
(nfbodies (mapfuncall #'(lambda (f) `#'(lambda ,@(cdr f))) fns)))
`(let ,(mapfuncall #'(lambda (nf) `(,nf #'(lambda () ()))) nfnames)
(flet ,(mapfuncall #'(lambda (f nf) `(,f (&rest a) (apply ,nf a)))
fnames nfnames)
(flet ,fns
(progn ,@(mapfuncall #'(lambda (f nf) `(setq ,nf #',f))
fnames nfnames))
,@forms)))))
;;(* + - / /= < <= = > > >= ABS ACONS ACOS ADJOIN ALPHA-CHAR-P ALPHANUMERICP APPEND AREF ASH ASIN ASSOC ASSOC-IF ATAN ATOM
;;BOOLE BOOLEAN BOTH-CASE-P BQ-CONS BQ-VECTOR BUTLAST BYTE CAAR CADR CAR CCONCATENATE CDAR CDDR CDR CEILING CERROR CHAR CHAR-CODE CHAR-DOWNCASE CHAR-EQUAL CHAR-GREATERP CHAR-LESSP CHAR-NOT-EQUAL CHAR-NOT-GREATERP CHAR-NOT-LESSP CHAR-UPCASE CHAR/= CHAR< CHAR<= CHAR= CHAR> CHAR>= CHARACTERP CLRHASH
;;CMERGE CODE-CHAR CONS CONSP CONSTANTP CONSTRUCT-FILENAME COPY-ALIST COPY-LIST COPY-SEQ COPY-TREE COS COUNT COUNT-IF CREDUCE CURRENT-PROCESS DATE-RELATIVE-GUID-P DECODE-FLOAT DECODE-UNIVERSAL-TIME DELETE DELETE-DUPLICATES DELETE-IF DIGIT-CHAR DIGIT-CHAR-P DISASSEMBLE-INTEGER-TO-FIXNUMS DPB EIGHTH ELT ENCODE-UNIVERSAL-TIME ENDP EQ EQL EQUAL EQUALP EVENP EXIT EXP EXPT FALSE FIFTH FILL FIND FIND-IF FIND-PACKAGE FIND-SYMBOL FIRST FIXNUMP FLOAT FLOAT-DIGITS FLOAT-RADIX FLOAT-SIGN FLOATP FLOOR FORCE-OUTPUT FORMAT FOURTH FRESH-LINE FUNCTION-SPEC-P FUNCTIONP GC GC-DYNAMIC GC-EPHEMERAL GC-FULL GENSYM GENTEMP GET GET-DECODED-TIME GET-INTERNAL-REAL-TIME GET-INTERNAL-REAL-TIME GET-INTERNAL-RUN-TIME GET-UNIVERSAL-TIME GET-UNIVERSAL-TIME GETF GETHASH GETHASH-WITHOUT-VALUES GUID-P GUID-STRING-P GUID-TO-STRING GUID/= GUID< GUID<= GUID= GUID> GUID>= HASH-TABLE-COUNT HASH-TABLE-P HASH-TABLE-SIZE HASH-TABLE-TEST IDENTITY IGNORE INFINITY-P INT/ INTEGER-DECODE-FLOAT INTEGER-LENGTH INTEGERP INTERN INTERRUPT-PROCESS INTERSECTION ISQRT KEYWORDP KILL-PROCESS LAST LDB LDIFF LENGTH LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION LIST LIST* LIST-ALL-PACKAGES LIST-LENGTH LISTP LISTP LOCK-IDLE-P LOCK-P LOG LOGAND LOGANDC1 LOGANDC2 LOGBITP LOGCOUNT LOGEQV LOGIOR LOGNAND LOGNOR LOGNOT LOGORC1 LOGORC2 LOGTEST LOGXOR LOWER-CASE-P MAKE-HASH-TABLE MAKE-LOCK MAKE-LOCK MAKE-STRING MAKUNBOUND MAX MEMBER MEMBER-IF MIN MINUSP MISMATCH MOD NBUTLAST NCONC NEW-GUID NINTERSECTION NINTH NOT-A-NUMBER-P NOTE-PERCENT-PROGRESS NOTIFY NRECONC NREVERSE NSET-DIFFERENCE NSET-EXCLUSIVE-OR NSTRING-CAPITALIZE NSTRING-DOWNCASE NSTRING-UPCASE NSUBLIS NSUBST NSUBST-IF NSUBSTITUTE NSUBSTITUTE-IF NTH NTHCDR NULL NUMBERP NUMBERP NUNION ODDP PAIRLIS PEEK-CHAR PLUSP POSITION POSITION-IF PRIN1 PRIN1-TO-STRING PRINC PRINC-TO-STRING PRINT PROCESS-ACTIVE-P PROCESS-BLOCK PROCESS-NAME PROCESS-STATE PROCESS-UNBLOCK PROCESS-WAIT PROCESS-WAIT-WITH-TIMEOUT PROCESS-WHOSTATE PROCESSP RANDOM RASSOC RASSOC-IF READ-FROM-STRING READ-FROM-STRING-IGNORING-ERRORS REM REMF REMHASH REMOVE REMOVE-DUPLICATES REMOVE-IF REPLACE REST REVAPPEND REVERSE REVERSE ROOM ROUND RPLACA RPLACD SCALE-FLOAT SEARCH SECOND SEED-RANDOM SEQUENCEP SET-AREF SET-CONSING-STATE SET-DIFFERENCE SET-NTH SEVENTH SHOW-PROCESSES SIN SIXTH QUIT SLEEP SORT SQRT STABLE-SORT STRING STRING-CAPITALIZE STRING-DOWNCASE STRING-EQUAL STRING-GREATERP STRING-LEFT-TRIM STRING-LESSP STRING-NOT-EQUAL STRING-NOT-GREATERP STRING-NOT-LESSP STRING-RIGHT-TRIM STRING-TO-GUID STRING-TRIM STRING-UPCASE STRING/= STRING< STRING<= STRING= STRING> STRING>= STRINGP SUBLIS SUBLISP::PROPERTY-LIST-MEMBER SUBSEQ SUBSETP SUBST SUBST-IF SUBSTITUTE SUBSTITUTE-IF SXHASH SYMBOL-FUNCTION SYMBOL-NAME SYMBOLP SYMBOLP TAILP TAN TENTH TERPRI THIRD TREE-EQUAL TRUE TRUNCATE TYPE-OF UNINTERN UNION UPPER-CASE-P VALID-PROCESS-P VALUES VECTOR VECTORP WARN WRITE-IMAGE Y-OR-N-P YES-OR-NO-P ZEROP)
(defmacro HANDLER-CASE-CAD (FORM &REST CASES)
(ret (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES)))
(IF NO-ERROR-CLAUSE
(LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN"))
(ERROR-RETURN (MAKE-SYMBOL "ERROR-RETURN")))
`(BLOCK ,ERROR-RETURN
(MULTIPLE-VALUE-CALL #'(lambda ,@(CDR NO-ERROR-CLAUSE))
(BLOCK ,NORMAL-RETURN
(retURN-FROM ,ERROR-RETURN
(HANDLER-CASE (retURN-FROM ,NORMAL-RETURN ,FORM)
,@(REMOVE NO-ERROR-CLAUSE CASES)))))))
(LET ((TAG (GENSYM))
(VAR (GENSYM))
(ANNOTATED-CASES (MAPCAR #'(lambda (CASE) (CONS (GENSYM) CASE))
CASES)))
`(BLOCK ,TAG
(LET ((,VAR NIL))
,VAR ;ignorable
(TAGBODY
(HANDLER-BIND ,(MAPCAR #'(lambda (ANNOTATED-CASE)
(LIST (CADR ANNOTATED-CASE)
`#'(lambda (TEMP)
,@(IF (CADDR ANNOTATED-CASE)
`((SETQ ,VAR TEMP)))
(GO ,(CAR ANNOTATED-CASE)))))
ANNOTATED-CASES)
(retURN-FROM ,TAG ,FORM))
,@(MAPCAN #'(lambda (ANNOTATED-CASE)
(LIST (CAR ANNOTATED-CASE)
(LET ((BODY (CDDDR ANNOTATED-CASE)))
`(retURN-FROM ,TAG
,(COND ((CADDR ANNOTATED-CASE)
`(LET ((,(CAADDR ANNOTATED-CASE)
,VAR))
,@BODY))
((NOT (CDR BODY))
(CAR BODY))
(T
`(PROGN ,@BODY)))))))
ANNOTATED-CASES)))))))))
|#
;;(defun repl (&optional (stream *STANDARD-IO*))
#|
;;Initialize the task processor pool for requests.
(INITIALIZE-API-TASK-PROCESSORS)
;;Initialize the task processor pool for requests.
(INITIALIZE-BG-TASK-PROCESSORS )
;;Initialize the task processor pool for requests.
(INITIALIZE-CONSOLE-TASK-PROCESSORS )
(SHOW-API-TASK-PROCESSORS )
;;Provides a convenient alias for DISPLAY-API-TASK-PROCESSORS.
(SHOW-API-TP-MSGS )
;;Show and reset the task processor background messages for thetask-process-pool.
(SHOW-BG-TP-MSGS )
;;Show and reset the task processor background messages for thetask-process-pool.
(SHOW-CONSOLE-TP-MSGS )
;;(TRANSLATOR-RET-OPTIMIZE-BODY )
|#
;;(defvar *COMMON-LISP-USER-PACKAGE* (make-package "COMMON-LISP-USER" '("CL" "CYC") '("USER")))
;;(defun dispatch-macro-IN-PACKAGE (s c n))
;;(lisp)
(print '(load "common.lisp")) (terpri)
;;(load "cl.lisp")
;;DMILES!!! (defun char-int (char) (ret (char-code char )))
#|
(defmacro defun (suggest pattern &rest body)
(ret `(eval '(trace-progn (defun ,suggest ,@(transform-varblock suggest pattern body))))))
(defmacro shadow-defun (package name &rest args-body)
;;(pwhen (consp name)(null name)(csetq package *PACKAGE* name package args-body (cons name args-body)))
(clet ((cl (make-shadow name package)))
(ret `(defun ,cl ,@(transform-varblock cl (car args-body)(cdr args-body))))))
(defmacro shadow-macro (package name &rest args-body)
;;(pwhen (consp name)(null name)(csetq package *PACKAGE* name package args-body (cons name args-body)))
;;(FORCE-PRINT (list 'shadow-macro (trace-symbol name) package))
(clet ((cl (make-shadow name package)))
(ret `(defmacro ,cl ,@(transform-varblock cl (car args-body)(cdr args-body))))))
|#
;;EXPAND-define-LIST-ELEMENT-PREDICATOR (FUNCTION-NAME FUNCTION-SCOPE ELEMENT-VAR TYPE BODY)
;;ARGNAMES-FROM-ARGLIST
;;MAKE-PROCESS-WITH-ARGS (NAME FUNCTION &OPTIONAL ARGS)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;trace-symbol
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *all-shadowing-symbols*)
(defun shadow-push (package sym))
(defvar *sticky-symbols* '((*SUBLISP-PACKAGE* . LAMBDA)(*SUBLISP-PACKAGE* . LAMBDA)(*SUBLISP-PACKAGE* . NIL)))
(defmacro map-each (var fn list &rest body)
(ret `(mapfuncall #'(lambda (e) (ret (trace (apply ,fn (cons e ,body))))) list)))
;;(cdo ((i 0 (1+ i))) ((= i 10))(format t "~a,~a~%" i (constant-name (find-constant-by-internal-id i))))
;;(cdo ((i 0 (1+ i))) ((= i (constant-count)))(format t "~a,~a~%" i (constant-name (find-constant-by-internal-id i))))
(defun best-symbol (current &optional packsearch)
(fif current
(fif (consp current)
(cons (best-symbol (car current) packsearch)(best-symbol (cdr current) packsearch))
(fif (symbolp current)
(clet ((initial current))
(cdolist (into (consify (fif packsearch packsearch (list-all-packages))))
(csetq current (better-symbol current
(find-symbol (string (nstring current))(string (nstring into))))))
(csetq current (better-symbol initial current))
(FORCE-format t "; Using ~a from ~a %" (trace-symbol current) (trace-symbol initial))
(ret current)))))
(ret current))
(defun better-symbol (sujjest current)
(ret (> (symbol-worth sujject)(symbol-worth current))))
(defun use-symbol (symbols &optional (target *package*) (keep #'better-symbol) (inheriting :external))
(csetq target (coerce-package target))
(fif (consp symbols) (ret (mapfuncall #'(lambda (x) (ret (use-symbol x target keep))) symbols)))
(punless (cand symbols (symbolp symbols)) symbols)
(clet ((from *package*)(name (symbol-name symbols))(package (symbol-package symbols)))
(cmultiple-value-bind (suggest pstatus) (find-symbol name package)
(pwhen (cnot (eq symbols suggest)) (FORCE-format t "; Rotten symbol ~a instead of ~a~%" (trace-symbol suggest package)
(trace-symbol symbols package)))
(cmultiple-value-bind (visible tstatus) (find-symbol name target)
(pcond
((null visible))
((eq suggest visible) (ret (values visible tstatus))) ;; (FORCE-format t ";;~a ~a~%" tstatus (trace-symbol suggest target))
((cand (functionp keep)(eq visible (funcall keep suggest visible)))
(FORCE-format t "; Keeping ~a instead of ~a mode = ~a~%" (trace-symbol visible target) (trace-symbol suggest target) pstatus)
(ret (values visible tstatus)))
((null suggest) (ret (values NIL NIL))) ;; (FORCE-format t ";;~a ~a~%" tstatus (trace-symbol suggest target))
(t
(FORCE-format t "; Using ~a instead of ~a mode = ~a~%" (trace-symbol suggest target) (trace-symbol visible target) tstatus)
(shadow-push package visible)
(pwhen (equal tstatus :inherited) (import visible target))
(csetq pstatus tstatus)
(trace-warn (unintern visible target)))))
(pcase pstatus
(:internal ;;(FORCE-format t ";;Interning ~a~%" (trace-symbol suggest target))
(import suggest target)(intern suggest target))
(:external ;;(FORCE-format t ";;Exporting ~a~%" (trace-symbol suggest target))
(import suggest target)(intern suggest target)(export suggest target))
(:inherited ;;(FORCE-format t ";;Inheriting ~a~%" (trace-symbol suggest target))
(import suggest target)(export suggest target)))
(ret (values suggest pstatus)))))
(defun contains-type (sv type)
(pcond
((null sv) nil)
((numberp sv) nil)
((equal (type-of sv) type) sv)
((consp sv)
(pcond
((contains-type (car sv) type))
((contains-type (cdr sv) type))))
((symbolp sv)
(pcond
((fif (boundp sv)(contains-type (symbol-value sv) type)))
((contains-type (symbol-plist sv) type))))
((hash-table-p sv)
(pcond
((contains-type (HASH-TABLE-keys sv) type))
((contains-type (HASH-TABLE-values sv) type))))))
(defun boundp-contains (type)
(clet ((lastsym))
(cdolist (pack (list *CYC-PACKAGE* *SUBLISP-PACKAGE*))
(cdo-symbols (sym pack)
(print sym)
(FORCE-output)
(clet ((res (contains-type lastsym type)))
(pwhen res
(print (list res lastsym))))
(csetq lastsym sym)))))
(defun b () (boundp-contains 'hash-table))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;USE-PACKAGE
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun USE-PACKAGE (package &optional (target *package*) (keep #'better-symbol)(inheriting :external)done)
(csetq target (coerce-package target))
(cdolist (pack (consify package))
(csetq pack (coerce-package pack))
(cdo-symbols (sym pack) (csetq done (cons (use-symbol sym target keep inheriting) done))))
(ret done))
(defun import-in-all (symbols &optional importpacks)
(cdolist (into (consify (fif importpacks importpacks (list-all-packages))))
(import symbols into)))
;;Shadowing-Import -- Public
;;
;; If a conflicting symbol is present, unintern it, otherwise just
;;stick the symbol in.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;defun shadow functions and macros
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(lock-package :SYSTEM)
;;Shadow -- Public
;;
;;
(defun shadow (suggest &optional (package *package*))
"Make an internal symbol in Package with the same name as each of the
specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
If a symbol with the given name is already present in Package, then
the existing symbol is placed in the shadowing symbols list if it is
not already present."
(let ((name (symbol-name suggest))(package (coerce-package package)))
(multiple-value-bind (s w) (find-symbol name package)
(pwhen (cor (cnot w) (eq w :inherited))
(csetq s (make-symbol name))
(intern s package))
(shadow-push package s)))
(ret t))
;;Shadowing-Import -- Public
;;
;; If a conflicting symbol is present, unintern it, otherwise just
;;stick the symbol in.
;;
(defun shadowing-import (sym &optional (package *package*))
"Import Symbols into package, disregarding any name conflict. If
a symbol of the same name is present, then it is uninterned.
The symbols are added to the Package-Shadowing-Symbols."
(let ((package (coerce-package package)))
(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
(punless (cand w (cnot (eq w :inherited)) (eq s sym))
(pwhen (cor (eq w :internal) (eq w :external))
;;
;;If it was shadowed, we don't want Unintern to flame out...
;;(csetq *all-shadowing-symbols* (remove (cons package s)))
(unintern s package))
(intern sys package))
(shadow-push package sym)))
(ret t))
(punless (fboundp 'defmethod) (defmacro defmethod (name pattern &rest body)(ret `(defun ',name ',pattern ,@body))))
(describe-package :SL)
(IN-PACKAGE (package-name *LOADER-PACKAGE*))
(FORCE-PRINT ";; LOADED COMMON.LISP!")