X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=286069dcc7d337e65e35985c35b2e75f96588e99;hb=30a1bbb8152583d8f7afadb4e1d89b6a0fe3353b;hp=d369798eb2198e1ad25749212f90a2f730d59205;hpb=954f67d2bd220a9236f89a23b2b87f8678c3530e;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index d369798..286069d 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -45,15 +45,17 @@ (defmacro unless (condition &body body) `(if ,condition nil (progn ,@body))) - (defmacro defvar (name value) + (defmacro defvar (name value &optional docstring) `(progn (unless (boundp ',name) (setq ,name ,value)) + ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring))) ',name)) - (defmacro defparameter (name value) + (defmacro defparameter (name value &optional docstring) `(progn (setq ,name ,value) + ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring))) ',name)) (defmacro named-lambda (name args &rest body) @@ -65,9 +67,12 @@ (defmacro defun (name args &rest body) `(progn (fset ',name - (named-lambda ,(symbol-name name) - ,args - (block ,name ,@body))) + (named-lambda ,(symbol-name name) ,args + ,@(when (stringp (car body)) `(,(car body))) + (block ,name + ,@(if (stringp (car body)) + (cdr body) + body)))) ',name)) (defvar *package* (new)) @@ -117,7 +122,11 @@ (defun cons (x y ) (cons x y)) (defun consp (x) (consp x)) - (defun car (x) (car x)) + + (defun car (x) + "Return the CAR part of a cons, or NIL if X is null." + (car x)) + (defun cdr (x) (cdr x)) (defun caar (x) (car (car x))) (defun cadr (x) (car (cdr x))) @@ -436,8 +445,19 @@ (defun disassemble (function) (write-line (lambda-code (fdefinition function))) - nil)) - + nil) + + (defun documentation (x type) + "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION." + (ecase type + (function + (let ((func (fdefinition x))) + (oget func "docstring"))) + (variable + (unless (symbolp x) + (error "Wrong argument type! it should be a symbol")) + (oget x "vardoc")))) + ) ;;; The compiler offers some primitives and special forms which are ;;; not found in Common Lisp, for instance, while. So, we grow Common @@ -749,6 +769,9 @@ (defun binding-name (b) (first b)) (defun binding-type (b) (second b)) (defun binding-value (b) (third b)) +(defun set-binding-value (b value) + (setcar (cdr (cdr b)) value)) + (defun binding-declared (b) (and b (fourth b))) (defun mark-binding-as-declared (b) @@ -863,68 +886,85 @@ (error "Bad lambda-list")) (car rest))) + +(defun lambda-docstring-wrapper (docstring &rest strs) + (if docstring + (js!selfcall + "var func = " (join strs) ";" *newline* + "func.docstring = '" docstring "';" *newline* + "return func;" *newline*) + (join strs))) + (define-compilation lambda (lambda-list &rest body) (let ((required-arguments (lambda-list-required-arguments lambda-list)) (optional-arguments (lambda-list-optional-arguments lambda-list)) - (rest-argument (lambda-list-rest-argument lambda-list))) + (rest-argument (lambda-list-rest-argument lambda-list)) + documentation) + ;; Get the documentation string for the lambda function + (when (and (stringp (car body)) + (not (null (cdr body)))) + (setq documentation (car body)) + (setq body (cdr body))) (let ((n-required-arguments (length required-arguments)) (n-optional-arguments (length optional-arguments)) (*environment* (extend-local-env (append (ensure-list rest-argument) required-arguments optional-arguments)))) - (concat "(function (" - (join (mapcar #'translate-variable - (append required-arguments optional-arguments)) - ",") - "){" *newline* - ;; Check number of arguments - (indent - (if required-arguments - (concat "if (arguments.length < " (integer-to-string n-required-arguments) - ") throw 'too few arguments';" *newline*) - "") - (if (not rest-argument) - (concat "if (arguments.length > " - (integer-to-string (+ n-required-arguments n-optional-arguments)) - ") throw 'too many arguments';" *newline*) - "") - ;; Optional arguments - (if optional-arguments - (concat "switch(arguments.length){" *newline* - (let ((optional-and-defaults - (lambda-list-optional-arguments-with-default lambda-list)) - (cases nil) - (idx 0)) - (progn - (while (< idx n-optional-arguments) - (let ((arg (nth idx optional-and-defaults))) - (push (concat "case " - (integer-to-string (+ idx n-required-arguments)) ":" *newline* - (translate-variable (car arg)) - "=" - (ls-compile (cadr arg)) - ";" *newline*) - cases) - (incf idx))) - (push (concat "default: break;" *newline*) cases) - (join (reverse cases)))) - "}" *newline*) - "") - ;; &rest/&body argument - (if rest-argument - (let ((js!rest (translate-variable rest-argument))) - (concat "var " js!rest "= " (ls-compile nil) ";" *newline* - "for (var i = arguments.length-1; i>=" - (integer-to-string (+ n-required-arguments n-optional-arguments)) - "; i--)" *newline* - (indent js!rest " = " - "{car: arguments[i], cdr: ") js!rest "};" - *newline*)) - "") - ;; Body - (ls-compile-block body t)) *newline* - "})")))) + (lambda-docstring-wrapper + documentation + "(function (" + (join (mapcar #'translate-variable + (append required-arguments optional-arguments)) + ",") + "){" *newline* + ;; Check number of arguments + (indent + (if required-arguments + (concat "if (arguments.length < " (integer-to-string n-required-arguments) + ") throw 'too few arguments';" *newline*) + "") + (if (not rest-argument) + (concat "if (arguments.length > " + (integer-to-string (+ n-required-arguments n-optional-arguments)) + ") throw 'too many arguments';" *newline*) + "") + ;; Optional arguments + (if optional-arguments + (concat "switch(arguments.length){" *newline* + (let ((optional-and-defaults + (lambda-list-optional-arguments-with-default lambda-list)) + (cases nil) + (idx 0)) + (progn + (while (< idx n-optional-arguments) + (let ((arg (nth idx optional-and-defaults))) + (push (concat "case " + (integer-to-string (+ idx n-required-arguments)) ":" *newline* + (translate-variable (car arg)) + "=" + (ls-compile (cadr arg)) + ";" *newline*) + cases) + (incf idx))) + (push (concat "default: break;" *newline*) cases) + (join (reverse cases)))) + "}" *newline*) + "") + ;; &rest/&body argument + (if rest-argument + (let ((js!rest (translate-variable rest-argument))) + (concat "var " js!rest "= " (ls-compile nil) ";" *newline* + "for (var i = arguments.length-1; i>=" + (integer-to-string (+ n-required-arguments n-optional-arguments)) + "; i--)" *newline* + (indent js!rest " = " + "{car: arguments[i], cdr: ") js!rest "};" + *newline*)) + "") + ;; Body + (ls-compile-block body t)) *newline* + "})")))) (define-compilation setq (var val) (let ((b (lookup-in-lexenv var *environment* 'variable))) @@ -1453,7 +1493,19 @@ (defun ls-macroexpand-1 (form) (let ((macro-binding (macro (car form)))) (if macro-binding - (apply (eval (binding-value macro-binding)) (cdr form)) + (let ((expander (binding-value macro-binding))) + (when (listp expander) + (let ((compiled (eval expander))) + ;; The list representation are useful while + ;; bootstrapping, as we can dump the definition of the + ;; macros easily, but they are slow because we have to + ;; evaluate them and compile them now and again. So, let + ;; us replace the list representation version of the + ;; function with the compiled one. + ;; + #+ecmalisp (set-binding-value macro-binding compiled) + (setq expander compiled))) + (apply expander (cdr form))) form))) (defun compile-funcall (function args)