- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl] Pushed new branch set-secret-detection-config-1
by Raymond Toy (＠rtoy) 31 Aug '22

31 Aug '22

Raymond Toy pushed new branch set-secret-detection-config-1 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/set-secret-detection-conf… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Add missing semicolon for macos
by Raymond Toy (＠rtoy) 31 Aug '22

31 Aug '22

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: e0ecf7d2 by Raymond Toy at 2022-08-30T17:17:58-07:00 Add missing semicolon for macos - - - - - 1 changed file: - src/lisp/os-common.c Changes: ===================================== src/lisp/os-common.c ===================================== @@ -750,7 +750,7 @@ os_software_version() strcat(version, " "); strcat(version, uts.version); #else - strcpy(version, uts.version) + strcpy(version, uts.version); #endif } } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e0ecf7d2289535975e839b9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e0ecf7d2289535975e839b9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Move documentation function from misc.lisp to misc-doc.lisp
by Raymond Toy (＠rtoy) 31 Aug '22

31 Aug '22

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: eb415b6d by Raymond Toy at 2022-08-30T17:04:01-07:00 Move documentation function from misc.lisp to misc-doc.lisp pclcom.lisp loads misc to get the documentation functions. This causes a problem when building cmucl with the new os_software_type function because it's undefined on the first build because we haven't defined it yet. To simplify things, move the documentation functions from misc.lisp to misc-doc.lisp so that pclcom can just load misc-doc to get just what is needed. This allows the build to proceed with os_software_type being undefined in the first build. - - - - - 5 changed files: - + src/code/misc-doc.lisp - src/code/misc.lisp - src/tools/pclcom.lisp - src/tools/worldbuild.lisp - src/tools/worldcom.lisp Changes: ===================================== src/code/misc-doc.lisp ===================================== @@ -0,0 +1,119 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/misc.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Documentation functions. Needed by pclcom.lisp +(in-package "LISP") +(intl:textdomain "cmucl") + +(export '(documentation)) + +;;; cobbled from stuff in describe.lisp. +(defun function-doc (x) + (let ((name + (case (kernel:get-type x) + (#.vm:closure-header-type + (kernel:%function-name (%closure-function x))) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (kernel:%function-name x)) + (#.vm:funcallable-instance-header-type + (typecase x + (kernel:byte-function + (c::byte-function-name x)) + (kernel:byte-closure + (c::byte-function-name (byte-closure-function x))) + (eval:interpreted-function + (multiple-value-bind + (exp closure-p dname) + (eval:interpreted-function-lambda-expression x) + (declare (ignore exp closure-p)) + dname)) + (t ;; funcallable-instance + (kernel:%function-name + (kernel:funcallable-instance-function x)))))))) + (when (and name (typep name '(or symbol cons))) + (values (info function documentation name))))) + +(defun documentation (x doc-type) + "Returns the documentation string of Doc-Type for X, or NIL if + none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, + SETF, and T." + (flet (;; CMUCL random-documentation. + (try-cmucl-random-doc (x doc-type) + (declare (symbol doc-type)) + (cdr (assoc doc-type + (values (info random-documentation stuff x)))))) + (case doc-type + (variable + (typecase x + (symbol (values (info variable documentation x))))) + (function + (typecase x + (symbol (values (info function documentation x))) + (function (function-doc x)) + (list ;; Must be '(setf symbol) + (values (info function documentation (cadr x)))))) + (structure + (typecase x + (symbol (when (eq (info type kind x) :instance) + (values (info type documentation x)))))) + (type + (typecase x + (kernel::structure-class (values (info type documentation (%class-name x)))) + (t (and (typep x 'symbol) (values (info type documentation x)))))) + (setf (info setf documentation x)) + ((t) + (typecase x + (function (function-doc x)) + (package (package-doc-string x)) + (kernel::structure-class (values (info type documentation (%class-name x)))) + (symbol (try-cmucl-random-doc x doc-type)))) + (t + (typecase x + (symbol (try-cmucl-random-doc x doc-type))))))) + +(defun (setf documentation) (string name doc-type) + #-no-docstrings + (case doc-type + (variable + #+nil + (when string + (%primitive print "Set variable text domain") + (%primitive print (symbol-name name)) + (%primitive print intl::*default-domain*)) + (setf (info variable textdomain name) intl::*default-domain*) + (setf (info variable documentation name) string)) + (function + #+nil + (when intl::*default-domain* + (%primitive print "Set function text domain") + (%primitive print (symbol-name name)) + (%primitive print intl::*default-domain*)) + (setf (info function textdomain name) intl::*default-domain*) + (setf (info function documentation name) string)) + (structure + (unless (eq (info type kind name) :instance) + (error (intl:gettext "~S is not the name of a structure type.") name)) + (setf (info type textdomain name) intl::*default-domain*) + (setf (info type documentation name) string)) + (type + (setf (info type textdomain name) intl::*default-domain*) + (setf (info type documentation name) string)) + (setf + (setf (info setf textdomain name) intl::*default-domain*) + (setf (info setf documentation name) string)) + (t + (let ((pair (assoc doc-type (info random-documentation stuff name)))) + (if pair + (setf (cdr pair) string) + (push (cons doc-type string) + (info random-documentation stuff name)))))) + string) + ===================================== src/code/misc.lisp ===================================== @@ -17,7 +17,7 @@ (in-package "LISP") (intl:textdomain "cmucl") -(export '(documentation *features* variable room +(export '(*features* variable room lisp-implementation-type lisp-implementation-version machine-type machine-version machine-instance software-type software-version short-site-name long-site-name dribble compiler-macro)) ===================================== src/tools/pclcom.lisp ===================================== @@ -12,7 +12,7 @@ (when (find-package "PCL") ;; Load the lisp:documentation functions. - (load "target:code/misc") + (load "target:code/misc-doc") ;; ;; Blow away make-instance optimizer so that it doesn't confuse ===================================== src/tools/worldbuild.lisp ===================================== @@ -113,6 +113,7 @@ "target:code/string" "target:code/mipsstrops" "target:code/misc" + "target:code/misc-doc" "target:code/dfixnum" ,@(unless (c:backend-featurep :gengc) '("target:code/gc")) ===================================== src/tools/worldcom.lisp ===================================== @@ -211,6 +211,7 @@ (comf "target:code/unidata") (comf "target:code/char") (comf "target:code/misc") +(comf "target:code/misc-doc") (comf "target:code/extensions" :byte-compile t) (comf "target:code/commandline") (comf "target:code/env-access") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/eb415b6d325669213ddb594… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/eb415b6d325669213ddb594… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Implement software-type in C
by Raymond Toy (＠rtoy) 30 Aug '22

30 Aug '22

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 3c1f5538 by Raymond Toy at 2022-08-30T06:27:12-07:00 Implement software-type in C Add function software-type to misc.lisp, and initialize to *software-type* to NIL so that (software-type) will set it appropriately. Add function os_software_type to os-common.c that returns the sysname slot of struct utsname. On Linux and macos, this value matches the value that we previously returned. In linux-os.lisp and bsd-os.lisp, comment out the code that sets *software-type*. (We need to do this for other OSes, still) - - - - - 4 changed files: - src/code/bsd-os.lisp - src/code/linux-os.lisp - src/code/misc.lisp - src/lisp/os-common.c Changes: ===================================== src/code/bsd-os.lisp ===================================== @@ -42,6 +42,7 @@ #+executable (register-lisp-runtime-feature :executable) +#+nil (setq *software-type* #+OpenBSD "OpenBSD" #+NetBSD "NetBSD" #+freebsd "FreeBSD" ===================================== src/code/linux-os.lisp ===================================== @@ -26,7 +26,7 @@ (register-lisp-feature :elf) (register-lisp-runtime-feature :executable) -(setq *software-type* "Linux") +;;(setq *software-type* "Linux") (defvar *software-version* nil "Version string for supporting software") ===================================== src/code/misc.lisp ===================================== @@ -183,11 +183,25 @@ "Returns a string giving the name of the local machine." (unix:unix-gethostname)) -(defvar *software-type* "Unix" - "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") +(defvar *software-type* nil + _N"The value of SOFTWARE-TYPE.") (defun software-type () - "Returns a string describing the supporting software." + _N"Returns a string describing the supporting software." + (unless *software-type* + (setf *software-type* + (let (software-type) + ;; Get the software-type from the C function os_software_type. + (unwind-protect + (progn + (setf software-type + (alien:alien-funcall + (alien:extern-alien "os_software_type" + (function (alien:* c-call:c-string))))) + (unless (zerop (sap-int (alien:alien-sap software-type))) + (alien:cast software-type c-call:c-string))) + (when software-type + (alien:free-alien software-type)))))) *software-type*) (defvar *short-site-name* (intl:gettext "Unknown") ===================================== src/lisp/os-common.c ===================================== @@ -757,3 +757,23 @@ os_software_version() return version; } +#undef UNAME_RELEASE_AND_VERSION + +char* +os_software_type() +{ + int status; + struct utsname uts; + char *os_name = NULL; + + status = uname(&uts); + if (status == 0) { + os_name = malloc(strlen(uts.sysname) + 1); + if (os_name) { + strcpy(os_name, uts.sysname); + } + } + + return os_name; +} + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3c1f5538b09c6256480aac2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3c1f5538b09c6256480aac2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-120-software-type-in-c
by Raymond Toy (＠rtoy) 30 Aug '22

30 Aug '22

Raymond Toy pushed new branch issue-120-software-type-in-c at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-120-software-type-i… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-130-file-author-in-c] Include stdlib.h and unistd.h
by Raymond Toy (＠rtoy) 29 Aug '22

29 Aug '22

Raymond Toy pushed to branch issue-130-file-author-in-c at cmucl / cmucl Commits: ec14c5b1 by Raymond Toy at 2022-08-29T14:07:02-07:00 Include stdlib.h and unistd.h stdlib.h is needed for malloc and friends. unistd.h is needed for sysconf. - - - - - 1 changed file: - src/lisp/os-common.c Changes: ===================================== src/lisp/os-common.c ===================================== @@ -11,8 +11,10 @@ #include <pwd.h> #include <stdbool.h> #include <stdio.h> +#include <stdlib.h> #include <string.h> #include <sys/stat.h> +#include <unistd.h> #include <time.h> #include "os.h" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ec14c5b16fc37e56023f069… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ec14c5b16fc37e56023f069… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-130-file-author-in-c] Use sysconf to get buffer size and add loop to increase size
by Raymond Toy (＠rtoy) 29 Aug '22

29 Aug '22

Raymond Toy pushed to branch issue-130-file-author-in-c at cmucl / cmucl Commits: fe9fa1db by Raymond Toy at 2022-08-29T12:05:30-07:00 Use sysconf to get buffer size and add loop to increase size Use sysconf to get the buffer size. If it fails, use a default and add a loop to keep trying with a larger buffer size (until some upper limit is reached.) - - - - - 1 changed file: - src/lisp/os-common.c Changes: ===================================== src/lisp/os-common.c ===================================== @@ -9,6 +9,7 @@ #include <math.h> #include <netdb.h> #include <pwd.h> +#include <stdbool.h> #include <stdio.h> #include <string.h> #include <sys/stat.h> @@ -725,21 +726,60 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u char * os_file_author(const char *path) { - int rc; + int status; struct stat statbuf; - char buf[16384]; char* author = NULL; + bool nomem = false; + size_t bufsize; + char* buf = NULL; + char* buf2 = NULL; struct passwd pwd; struct passwd *result = NULL; - rc = stat(path, &statbuf); + status = stat(path, &statbuf); - if (rc != 0) { + if (status != 0) { return NULL; } - rc = getpwuid_r(statbuf.st_uid, &pwd, buf, sizeof(buf), &result); + bufsize = sysconf(_SC_GETPW_R_SIZE_MAX); + /* + * If sysconf fails, just use a small initial buffer size that we + * will keep growing up to some maximum size. + */ + if (bufsize == -1) { + bufsize = 1024; + } + + while (1) { + buf2 = realloc(buf, bufsize); + fprintf(stderr, "buf2 = %p, size %zu\n", buf2, bufsize); + + if (buf2 == NULL) { + result = NULL; + nomem = true; + break; + } + + buf = buf2; + status = getpwuid_r(statbuf.st_uid, &pwd, buf, bufsize, &result); + + if (status != 0) { + result = NULL; + } + if ((result != NULL) || (status != ERANGE)) { + break; + } + /* If bufsize exceeds some large size, give up. */ + if (bufsize > 16384) { + nomem = true; + break; + } + + bufsize <<= 1; + } + if (result) { author = malloc(strlen(result->pw_name + 1)); if (author) { @@ -747,5 +787,7 @@ os_file_author(const char *path) } } + free(buf); + return author; } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fe9fa1dbfdc86cd86ae4f19… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fe9fa1dbfdc86cd86ae4f19… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-130-file-author-in-c] os_file_author returns a new string for the author
by Raymond Toy (＠rtoy) 29 Aug '22

29 Aug '22

Raymond Toy pushed to branch issue-130-file-author-in-c at cmucl / cmucl Commits: 82e485f4 by Raymond Toy at 2022-08-29T07:52:27-07:00 os_file_author returns a new string for the author Update file-author to call os_file_author correctly. - - - - - 2 changed files: - src/code/filesys.lisp - src/lisp/os-common.c Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1098,16 +1098,22 @@ optionally keeping some of the most recent old versions." :pathname file :format-control (intl:gettext "~S doesn't exist.") :format-arguments (list file))) - (alien:with-alien ((author (array c-call:char 1024))) - (unix::syscall* ("os_file_author" c-call:c-string - (alien:array c-call:char 1024) - c-call:int) - ;; Return - (alien:cast author c-call:c-string) - ;; Args - (unix::%name->file name) - author - 1024))))) + ;; unix-namestring converts "." to "". Convert it back to + ;; "." so we can stat the current directory. (Perhaps + ;; that's a bug in unix-namestring?) + (when (string= name "") + (setf name ".")) + (let (author) + (unwind-protect + (progn + (setf author (alien:alien-funcall + (alien:extern-alien "os_file_author" + (function (alien:* c-call:c-string) c-call:c-string)) + (unix::%name->file name))) + (unless (zerop (sap-int (alien:alien-sap author))) + (alien:cast author c-call:c-string))) + (when author + (alien:free-alien author))))))) ;;;; DIRECTORY. ===================================== src/lisp/os-common.c ===================================== @@ -717,36 +717,35 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u return rc; } -int -os_file_author(const char *path, char* author, int len) +/* + * Interface for file-author. Given a pathname, returns a new string + * holding the author of the file or NULL if some error occurred. The + * caller is responsible for freeing the memory used by the string. + */ +char * +os_file_author(const char *path) { int rc; struct stat statbuf; char buf[16384]; + char* author = NULL; struct passwd pwd; - struct passwd *result; + struct passwd *result = NULL; rc = stat(path, &statbuf); if (rc != 0) { - return rc; + return NULL; } rc = getpwuid_r(statbuf.st_uid, &pwd, buf, sizeof(buf), &result); if (result) { - if (strlen(result->pw_name) < len) { + author = malloc(strlen(result->pw_name + 1)); + if (author) { strcpy(author, result->pw_name); - } else { - strcpy(author, ""); - rc = -1; } } - return rc; + return author; } - - - - - View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/82e485f4e866c2c87643a17… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/82e485f4e866c2c87643a17… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-130-file-author-in-c
by Raymond Toy (＠rtoy) 26 Aug '22

26 Aug '22

Raymond Toy pushed new branch issue-130-file-author-in-c at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-130-file-author-in-c You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Add docstring for unix:unix-uname
by Raymond Toy (＠rtoy) 24 Aug '22

24 Aug '22

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 8b9a14fc by Raymond Toy at 2022-08-23T21:39:02-07:00 Add docstring for unix:unix-uname Update pot file too since the docstring changed. No functional changes. - - - - - 2 changed files: - src/code/unix.lisp - src/i18n/locale/cmucl-unix.pot Changes: ===================================== src/code/unix.lisp ===================================== @@ -2726,6 +2726,14 @@ (domainname (array char 65)))) (defun unix-uname () + _N"Unix-uname returns information from the uname(2) system call. + The return values are + + Name of the operating system + Name of this node within some implementation-defined network, if any + Release level of this operating system + Version level of this operating system release + Name of the hardware type on which the system is running" (with-alien ((names (struct utsname))) (syscall* (#-(or freebsd (and x86 solaris)) "uname" #+(and x86 solaris) "nuname" ; See /usr/include/sys/utsname.h ===================================== src/i18n/locale/cmucl-unix.pot ===================================== @@ -1365,6 +1365,18 @@ msgid "" " and its children." msgstr "" +#: src/code/unix.lisp +msgid "" +"Unix-uname returns information from the uname(2) system call.\n" +" The return values are\n" +"\n" +" Name of the operating system\n" +" Name of this node within some implementation-defined network, if any\n" +" Release level of this operating system\n" +" Version level of this operating system release\n" +" Name of the hardware type on which the system is running" +msgstr "" + #: src/code/unix.lisp msgid "" "Get the value of the environment variable named Name. If no such\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8b9a14fc3a2c684a538e68a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8b9a14fc3a2c684a538e68a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0