From: Eshel Yaron Date: Fri, 23 Sep 2022 12:47:04 +0000 (+0300) Subject: Cleanup after separating C parts X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=refs%2Fheads%2Fhost-module;p=sweep.git Cleanup after separating C parts --- diff --git a/Makefile b/Makefile index ca0f96d..5213c03 100644 --- a/Makefile +++ b/Makefile @@ -1,51 +1,18 @@ BASENAME = sweep -UNAME_S := $(shell uname -s) -ifeq ($(UNAME_S),Linux) - SOEXT = so -endif -ifeq ($(UNAME_S),Darwin) - SOEXT = dylib -endif +EMACS ?= emacs -SWIPL ?= swipl -SWIPLBASE = $(shell $(SWIPL) --dump-runtime-variables | grep PLBASE | cut -f 2 -d = | cut -f 1 -d ';') -SWIPLLIBDIR = $(shell $(SWIPL) --dump-runtime-variables | grep PLLIBDIR | cut -f 2 -d = | cut -f 1 -d ';') +.PHONY: clean check info -EMACS ?= emacs - -TARGET = $(BASENAME)-module.$(SOEXT) -OBJECT = $(BASENAME).o -SOURCE = $(BASENAME).c - -LDFLAGS += -shared -LDFLAGS += -L$(SWIPLLIBDIR) -LDFLAGS += -lswipl - -CFLAGS += -fPIC -CFLAGS += -Wall -CFLAGS += -Wextra -CFLAGS += -O2 -CFLAGS += -I$(SWIPLBASE)/include - -.PHONY: clean all check info - -all: $(TARGET) - -$(OBJECT): $(SOURCE) - $(CC) $(CFLAGS) -o $@ -c $(SOURCE) - -$(TARGET): $(OBJECT) - $(CC) -o $@ $(OBJECT) $(LDFLAGS) +check: $(TARGET) + $(EMACS) --batch --eval '(add-to-list (quote load-path) (expand-file-name "."))' \ + -l ert -l sweep -l sweep-tests.el -f ert-run-tests-batch-and-exit clean: - rm -f $(TARGET) $(OBJECT) $(BASENAME).info $(BASENAME).texi $(BASENAME).html + rm -f $(BASENAME).info $(BASENAME).texi $(BASENAME).html info: $(BASENAME).info + $(BASENAME).info:: README.org $(EMACS) -Q --batch --eval "(require 'ox-texinfo)" \ --eval "(with-current-buffer (find-file \"README.org\") (org-export-to-file (quote texinfo) \"$@\" nil nil nil nil nil (quote org-texinfo-compile)))" - -check: $(TARGET) - $(EMACS) --batch --eval '(add-to-list (quote load-path) (expand-file-name "."))' \ - -l ert -l sweep -l sweep-tests.el -f ert-run-tests-batch-and-exit diff --git a/emacs-module.h b/emacs-module.h deleted file mode 100644 index 268e5a4..0000000 --- a/emacs-module.h +++ /dev/null @@ -1,941 +0,0 @@ -/* emacs-module.h - GNU Emacs module API. - -Copyright (C) 2015-2022 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see . */ - -/* -This file defines the Emacs module API. Please see the chapter -`Dynamic Modules' in the GNU Emacs Lisp Reference Manual for -information how to write modules and use this header file. -*/ - -#ifndef EMACS_MODULE_H -#define EMACS_MODULE_H - -#include -#include -#include - -#ifndef __cplusplus -#include -#endif - -#define EMACS_MAJOR_VERSION 29 - -#if defined __cplusplus && __cplusplus >= 201103L -# define EMACS_NOEXCEPT noexcept -#else -# define EMACS_NOEXCEPT -#endif - -#if defined __cplusplus && __cplusplus >= 201703L -# define EMACS_NOEXCEPT_TYPEDEF noexcept -#else -# define EMACS_NOEXCEPT_TYPEDEF -#endif - -#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) -# define EMACS_ATTRIBUTE_NONNULL(...) \ - __attribute__ ((__nonnull__ (__VA_ARGS__))) -#elif (defined __has_attribute \ - && (!defined __clang_minor__ \ - || 3 < __clang_major__ + (5 <= __clang_minor__))) -# if __has_attribute (__nonnull__) -# define EMACS_ATTRIBUTE_NONNULL(...) \ - __attribute__ ((__nonnull__ (__VA_ARGS__))) -# endif -#endif -#ifndef EMACS_ATTRIBUTE_NONNULL -# define EMACS_ATTRIBUTE_NONNULL(...) -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -/* Current environment. */ -typedef struct emacs_env_29 emacs_env; - -/* Opaque pointer representing an Emacs Lisp value. - BEWARE: Do not assume NULL is a valid value! */ -typedef struct emacs_value_tag *emacs_value; - -enum { emacs_variadic_function = -2 }; - -/* Struct passed to a module init function (emacs_module_init). */ -struct emacs_runtime -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_runtime_private *private_members; - - /* Return an environment pointer. */ - emacs_env *(*get_environment) (struct emacs_runtime *runtime) - EMACS_ATTRIBUTE_NONNULL (1); -}; - -/* Type aliases for function pointer types used in the module API. - Note that we don't use these aliases directly in the API to be able - to mark the function arguments as 'noexcept' before C++20. - However, users can use them if they want. */ - -/* Function prototype for the module Lisp functions. These must not - throw C++ exceptions. */ -typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs, - emacs_value *args, - void *data) - EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); - -/* Function prototype for module user-pointer and function finalizers. - These must not throw C++ exceptions. */ -typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF; - -/* Possible Emacs function call outcomes. */ -enum emacs_funcall_exit -{ - /* Function has returned normally. */ - emacs_funcall_exit_return = 0, - - /* Function has signaled an error using `signal'. */ - emacs_funcall_exit_signal = 1, - - /* Function has exit using `throw'. */ - emacs_funcall_exit_throw = 2 -}; - -/* Possible return values for emacs_env.process_input. */ -enum emacs_process_input_result -{ - /* Module code may continue */ - emacs_process_input_continue = 0, - - /* Module code should return control to Emacs as soon as possible. */ - emacs_process_input_quit = 1 -}; - -/* Define emacs_limb_t so that it is likely to match GMP's mp_limb_t. - This micro-optimization can help modules that use mpz_export and - mpz_import, which operate more efficiently on mp_limb_t. It's OK - (if perhaps a bit slower) if the two types do not match, and - modules shouldn't rely on the two types matching. */ -typedef size_t emacs_limb_t; -#define EMACS_LIMB_MAX SIZE_MAX - -struct emacs_env_25 -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_env_private *private_members; - - /* Memory management. */ - - emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*free_global_ref) (emacs_env *env, emacs_value global_value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Non-local exit handling. */ - - enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_clear) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, emacs_value *symbol, emacs_value *data) - EMACS_ATTRIBUTE_NONNULL(1, 2, 3); - - void (*non_local_exit_signal) (emacs_env *env, - emacs_value symbol, emacs_value data) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Function registration. */ - - emacs_value (*make_function) (emacs_env *env, - ptrdiff_t min_arity, - ptrdiff_t max_arity, - emacs_value (*func) (emacs_env *env, - ptrdiff_t nargs, - emacs_value* args, - void *data) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1), - const char *docstring, - void *data) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - emacs_value (*funcall) (emacs_env *env, - emacs_value func, - ptrdiff_t nargs, - emacs_value* args) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*intern) (emacs_env *env, const char *name) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Type conversion. */ - - emacs_value (*type_of) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*is_not_nil) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) - EMACS_ATTRIBUTE_NONNULL(1); - - intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_integer) (emacs_env *env, intmax_t n) - EMACS_ATTRIBUTE_NONNULL(1); - - double (*extract_float) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_float) (emacs_env *env, double d) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - null-terminated string. - - SIZE must point to the total size of the buffer. If BUFFER is - NULL or if SIZE is not big enough, write the required buffer size - to SIZE and return true. - - Note that SIZE must include the last null byte (e.g. "abc" needs - a buffer of size 4). - - Return true if the string was successfully copied. */ - - bool (*copy_string_contents) (emacs_env *env, - emacs_value value, - char *buf, - ptrdiff_t *len) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - /* Create a Lisp string from a utf8 encoded string. */ - emacs_value (*make_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Embedded pointer type. */ - emacs_value (*make_user_ptr) (emacs_env *env, - void (*fin) (void *) EMACS_NOEXCEPT, - void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void *(*get_user_ptr) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) - (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, - emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) - EMACS_ATTRIBUTE_NONNULL(1); -}; - -struct emacs_env_26 -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_env_private *private_members; - - /* Memory management. */ - - emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*free_global_ref) (emacs_env *env, emacs_value global_value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Non-local exit handling. */ - - enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_clear) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, emacs_value *symbol, emacs_value *data) - EMACS_ATTRIBUTE_NONNULL(1, 2, 3); - - void (*non_local_exit_signal) (emacs_env *env, - emacs_value symbol, emacs_value data) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Function registration. */ - - emacs_value (*make_function) (emacs_env *env, - ptrdiff_t min_arity, - ptrdiff_t max_arity, - emacs_value (*func) (emacs_env *env, - ptrdiff_t nargs, - emacs_value* args, - void *data) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1), - const char *docstring, - void *data) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - emacs_value (*funcall) (emacs_env *env, - emacs_value func, - ptrdiff_t nargs, - emacs_value* args) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*intern) (emacs_env *env, const char *name) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Type conversion. */ - - emacs_value (*type_of) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*is_not_nil) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) - EMACS_ATTRIBUTE_NONNULL(1); - - intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_integer) (emacs_env *env, intmax_t n) - EMACS_ATTRIBUTE_NONNULL(1); - - double (*extract_float) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_float) (emacs_env *env, double d) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - null-terminated string. - - SIZE must point to the total size of the buffer. If BUFFER is - NULL or if SIZE is not big enough, write the required buffer size - to SIZE and return true. - - Note that SIZE must include the last null byte (e.g. "abc" needs - a buffer of size 4). - - Return true if the string was successfully copied. */ - - bool (*copy_string_contents) (emacs_env *env, - emacs_value value, - char *buf, - ptrdiff_t *len) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - /* Create a Lisp string from a utf8 encoded string. */ - emacs_value (*make_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Embedded pointer type. */ - emacs_value (*make_user_ptr) (emacs_env *env, - void (*fin) (void *) EMACS_NOEXCEPT, - void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void *(*get_user_ptr) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) - (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, - emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Returns whether a quit is pending. */ - bool (*should_quit) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); -}; - -struct emacs_env_27 -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_env_private *private_members; - - /* Memory management. */ - - emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*free_global_ref) (emacs_env *env, emacs_value global_value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Non-local exit handling. */ - - enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_clear) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, emacs_value *symbol, emacs_value *data) - EMACS_ATTRIBUTE_NONNULL(1, 2, 3); - - void (*non_local_exit_signal) (emacs_env *env, - emacs_value symbol, emacs_value data) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Function registration. */ - - emacs_value (*make_function) (emacs_env *env, - ptrdiff_t min_arity, - ptrdiff_t max_arity, - emacs_value (*func) (emacs_env *env, - ptrdiff_t nargs, - emacs_value* args, - void *data) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1), - const char *docstring, - void *data) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - emacs_value (*funcall) (emacs_env *env, - emacs_value func, - ptrdiff_t nargs, - emacs_value* args) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*intern) (emacs_env *env, const char *name) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Type conversion. */ - - emacs_value (*type_of) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*is_not_nil) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) - EMACS_ATTRIBUTE_NONNULL(1); - - intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_integer) (emacs_env *env, intmax_t n) - EMACS_ATTRIBUTE_NONNULL(1); - - double (*extract_float) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_float) (emacs_env *env, double d) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - null-terminated string. - - SIZE must point to the total size of the buffer. If BUFFER is - NULL or if SIZE is not big enough, write the required buffer size - to SIZE and return true. - - Note that SIZE must include the last null byte (e.g. "abc" needs - a buffer of size 4). - - Return true if the string was successfully copied. */ - - bool (*copy_string_contents) (emacs_env *env, - emacs_value value, - char *buf, - ptrdiff_t *len) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - /* Create a Lisp string from a utf8 encoded string. */ - emacs_value (*make_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Embedded pointer type. */ - emacs_value (*make_user_ptr) (emacs_env *env, - void (*fin) (void *) EMACS_NOEXCEPT, - void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void *(*get_user_ptr) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) - (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, - emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Returns whether a quit is pending. */ - bool (*should_quit) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Processes pending input events and returns whether the module - function should quit. */ - enum emacs_process_input_result (*process_input) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL (1); - - struct timespec (*extract_time) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_time) (emacs_env *env, struct timespec time) - EMACS_ATTRIBUTE_NONNULL (1); - - bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign, - ptrdiff_t *count, emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count, - const emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); -}; - -struct emacs_env_28 -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_env_private *private_members; - - /* Memory management. */ - - emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*free_global_ref) (emacs_env *env, emacs_value global_value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Non-local exit handling. */ - - enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_clear) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, emacs_value *symbol, emacs_value *data) - EMACS_ATTRIBUTE_NONNULL(1, 2, 3); - - void (*non_local_exit_signal) (emacs_env *env, - emacs_value symbol, emacs_value data) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Function registration. */ - - emacs_value (*make_function) (emacs_env *env, - ptrdiff_t min_arity, - ptrdiff_t max_arity, - emacs_value (*func) (emacs_env *env, - ptrdiff_t nargs, - emacs_value* args, - void *data) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1), - const char *docstring, - void *data) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - emacs_value (*funcall) (emacs_env *env, - emacs_value func, - ptrdiff_t nargs, - emacs_value* args) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*intern) (emacs_env *env, const char *name) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Type conversion. */ - - emacs_value (*type_of) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*is_not_nil) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) - EMACS_ATTRIBUTE_NONNULL(1); - - intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_integer) (emacs_env *env, intmax_t n) - EMACS_ATTRIBUTE_NONNULL(1); - - double (*extract_float) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_float) (emacs_env *env, double d) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - null-terminated string. - - SIZE must point to the total size of the buffer. If BUFFER is - NULL or if SIZE is not big enough, write the required buffer size - to SIZE and return true. - - Note that SIZE must include the last null byte (e.g. "abc" needs - a buffer of size 4). - - Return true if the string was successfully copied. */ - - bool (*copy_string_contents) (emacs_env *env, - emacs_value value, - char *buf, - ptrdiff_t *len) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - /* Create a Lisp string from a utf8 encoded string. */ - emacs_value (*make_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Embedded pointer type. */ - emacs_value (*make_user_ptr) (emacs_env *env, - void (*fin) (void *) EMACS_NOEXCEPT, - void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void *(*get_user_ptr) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) - (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, - emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Returns whether a quit is pending. */ - bool (*should_quit) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Processes pending input events and returns whether the module - function should quit. */ - enum emacs_process_input_result (*process_input) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL (1); - - struct timespec (*extract_time) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_time) (emacs_env *env, struct timespec time) - EMACS_ATTRIBUTE_NONNULL (1); - - bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign, - ptrdiff_t *count, emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count, - const emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); - - void (*(*EMACS_ATTRIBUTE_NONNULL (1) - get_function_finalizer) (emacs_env *env, - emacs_value arg)) (void *) EMACS_NOEXCEPT; - - void (*set_function_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL (1); - - int (*open_channel) (emacs_env *env, emacs_value pipe_process) - EMACS_ATTRIBUTE_NONNULL (1); - - void (*make_interactive) (emacs_env *env, emacs_value function, - emacs_value spec) - EMACS_ATTRIBUTE_NONNULL (1); - - /* Create a unibyte Lisp string from a string. */ - emacs_value (*make_unibyte_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); -}; - -struct emacs_env_29 -{ - /* Structure size (for version checking). */ - ptrdiff_t size; - - /* Private data; users should not touch this. */ - struct emacs_env_private *private_members; - - /* Memory management. */ - - emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*free_global_ref) (emacs_env *env, emacs_value global_value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Non-local exit handling. */ - - enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_clear) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, emacs_value *symbol, emacs_value *data) - EMACS_ATTRIBUTE_NONNULL(1, 2, 3); - - void (*non_local_exit_signal) (emacs_env *env, - emacs_value symbol, emacs_value data) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Function registration. */ - - emacs_value (*make_function) (emacs_env *env, - ptrdiff_t min_arity, - ptrdiff_t max_arity, - emacs_value (*func) (emacs_env *env, - ptrdiff_t nargs, - emacs_value* args, - void *data) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1), - const char *docstring, - void *data) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - emacs_value (*funcall) (emacs_env *env, - emacs_value func, - ptrdiff_t nargs, - emacs_value* args) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*intern) (emacs_env *env, const char *name) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Type conversion. */ - - emacs_value (*type_of) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*is_not_nil) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) - EMACS_ATTRIBUTE_NONNULL(1); - - intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_integer) (emacs_env *env, intmax_t n) - EMACS_ATTRIBUTE_NONNULL(1); - - double (*extract_float) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - - emacs_value (*make_float) (emacs_env *env, double d) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - null-terminated string. - - SIZE must point to the total size of the buffer. If BUFFER is - NULL or if SIZE is not big enough, write the required buffer size - to SIZE and return true. - - Note that SIZE must include the last null byte (e.g. "abc" needs - a buffer of size 4). - - Return true if the string was successfully copied. */ - - bool (*copy_string_contents) (emacs_env *env, - emacs_value value, - char *buf, - ptrdiff_t *len) - EMACS_ATTRIBUTE_NONNULL(1, 4); - - /* Create a Lisp string from a utf8 encoded string. */ - emacs_value (*make_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Embedded pointer type. */ - emacs_value (*make_user_ptr) (emacs_env *env, - void (*fin) (void *) EMACS_NOEXCEPT, - void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void *(*get_user_ptr) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) - (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) - EMACS_ATTRIBUTE_NONNULL(1); - - void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, - emacs_value value) - EMACS_ATTRIBUTE_NONNULL(1); - - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Returns whether a quit is pending. */ - bool (*should_quit) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL(1); - - /* Processes pending input events and returns whether the module - function should quit. */ - enum emacs_process_input_result (*process_input) (emacs_env *env) - EMACS_ATTRIBUTE_NONNULL (1); - - struct timespec (*extract_time) (emacs_env *env, emacs_value arg) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_time) (emacs_env *env, struct timespec time) - EMACS_ATTRIBUTE_NONNULL (1); - - bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign, - ptrdiff_t *count, emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); - - emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count, - const emacs_limb_t *magnitude) - EMACS_ATTRIBUTE_NONNULL (1); - - void (*(*EMACS_ATTRIBUTE_NONNULL (1) - get_function_finalizer) (emacs_env *env, - emacs_value arg)) (void *) EMACS_NOEXCEPT; - - void (*set_function_finalizer) (emacs_env *env, emacs_value arg, - void (*fin) (void *) EMACS_NOEXCEPT) - EMACS_ATTRIBUTE_NONNULL (1); - - int (*open_channel) (emacs_env *env, emacs_value pipe_process) - EMACS_ATTRIBUTE_NONNULL (1); - - void (*make_interactive) (emacs_env *env, emacs_value function, - emacs_value spec) - EMACS_ATTRIBUTE_NONNULL (1); - - /* Create a unibyte Lisp string from a string. */ - emacs_value (*make_unibyte_string) (emacs_env *env, - const char *str, ptrdiff_t len) - EMACS_ATTRIBUTE_NONNULL(1, 2); - - /* Add module environment functions newly added in Emacs 29 here. - Before Emacs 29 is released, remove this comment and start - module-env-30.h on the master branch. */ -}; - -/* Every module should define a function as follows. */ -extern int emacs_module_init (struct emacs_runtime *runtime) - EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL (1); - -#ifdef __cplusplus -} -#endif - -#endif /* EMACS_MODULE_H */ diff --git a/sweep.c b/sweep.c deleted file mode 100644 index 847d981..0000000 --- a/sweep.c +++ /dev/null @@ -1,636 +0,0 @@ -/* - Author: Eshel Yaron - E-mail: eshel@swi-prolog.org - Copyright (c) 2022, SWI-Prolog Solutions b.v. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. -*/ - -#include "emacs-module.h" -#include -#include -#include -#include -#include - -int plugin_is_GPL_compatible; - -term_t output_term = 0; -emacs_env * current_env = NULL; - -static int value_to_term(emacs_env*, emacs_value, term_t); -static emacs_value term_to_value(emacs_env*, term_t); - -void -ethrow(emacs_env *env, const char * message) { - ptrdiff_t len = strlen(message); - - emacs_value str = env->make_string(env, message, len); - emacs_value arg = env->funcall (env, env->intern (env, "list"), 1, &str); - env->non_local_exit_signal(env, env->intern(env, "error"), arg); -} - -char* -estring_to_cstring(emacs_env *eenv, emacs_value estring, ptrdiff_t *len_p) { - char * buf = NULL; - ptrdiff_t len = 0; - - if (len_p == NULL) len_p = &len; - - if (!eenv->copy_string_contents(eenv, estring, NULL, len_p)) { - ethrow(eenv, "Failed to get string length"); - return NULL; - } - if ((buf = (char*)malloc((*len_p))) == NULL) { - ethrow(eenv, "malloc failed"); - return NULL; - } - memset(buf, 0, (*len_p)); - if (!eenv->copy_string_contents(eenv, estring, buf, len_p)) { - ethrow(eenv, "Failed to copy string contents"); - free(buf); - buf = NULL; - } - - return buf; -} - -int -estring_to_pstring(emacs_env *eenv, emacs_value estring, term_t t) { - ptrdiff_t len = 0; - char *buf = NULL; - int i = 0; - - if ((buf = estring_to_cstring(eenv, estring, &len)) == NULL) return -1; - i = PL_put_chars(t, PL_STRING|REP_UTF8, len - 1, buf); - free(buf); - return i; -} - -static emacs_value -econs(emacs_env *env, emacs_value car, emacs_value cdr) { - emacs_value args[2] = {car, cdr}; - return env->funcall (env, env->intern (env, "cons"), 2, args); -} - -static emacs_value -ecar(emacs_env *env, emacs_value cons) { - return env->funcall (env, env->intern (env, "car"), 1, &cons); -} - -static emacs_value -ecdr(emacs_env *env, emacs_value cons) { - return env->funcall (env, env->intern (env, "cdr"), 1, &cons); -} - - -emacs_value -enil(emacs_env *env) { return env->intern(env, "nil"); } - -emacs_value -et(emacs_env *env) { return env->intern(env, "t"); } - -static emacs_value -term_to_value_list(emacs_env *eenv, term_t l) { - term_t ph = PL_new_term_ref(); - term_t pt = PL_new_term_ref(); - - if (PL_get_list(l, ph, pt)) { - return econs(eenv, term_to_value(eenv, ph), term_to_value(eenv, pt)); - } else return NULL; -} - -static emacs_value -term_to_value_integer(emacs_env *eenv, term_t t) { - emacs_value v = NULL; - int64_t l = -1; - if (PL_get_int64(t, &l)) { - v = eenv->make_integer(eenv, l); - } - return v; -} - -static emacs_value -term_to_value_float(emacs_env *eenv, term_t t) { - emacs_value v = NULL; - double l = -1; - if (PL_get_float(t, &l)) { - v = eenv->make_float(eenv, l); - } - return v; -} - -emacs_value -term_to_value_string(emacs_env *eenv, term_t t) { - char * string = NULL; - emacs_value v = NULL; - size_t l = -1; - if (PL_get_nchars(t, &l, &string, CVT_STRING|REP_UTF8)) { - v = eenv->make_string(eenv, string, l); - } - return v; -} - -emacs_value -term_to_value_atom(emacs_env *eenv, term_t t) { - char * string = NULL; - emacs_value v = NULL; - emacs_value s = NULL; - size_t l = -1; - - if (PL_get_nchars(t, &l, &string, CVT_ATOM|REP_UTF8)) { - s = eenv->make_string(eenv, string, l); - v = econs(eenv, eenv->intern(eenv, "atom"), s); - } - return v; -} - -emacs_value -term_to_value_variable(emacs_env *env, term_t t) { - (void)t; - return env->intern(env, "variable"); -} - -emacs_value -term_to_value_dict(emacs_env *env, term_t t) { - (void)t; - return env->intern(env, "dict"); -} - -emacs_value -term_to_value_blob(emacs_env *env, term_t t) { - (void)t; - return env->intern(env, "blob"); -} - -emacs_value -term_to_value_compound(emacs_env *env, term_t t) { - atom_t name = 0; - size_t arity = 0; - term_t arg = PL_new_term_ref(); - const char * chars = NULL; - size_t len = 0; - emacs_value * vals = NULL; - emacs_value res = NULL; - size_t n = 0; - - if (!PL_get_compound_name_arity(t, &name, &arity)) { - ethrow(env, "Not a compound"); - goto cleanup; - } - - chars = PL_atom_nchars(name, &len); - - vals = (emacs_value*)malloc(sizeof(emacs_value)*arity + 1); - if (vals == NULL) { - ethrow(env, "malloc failed"); - return NULL; - } - memset(vals, 0, sizeof(emacs_value)*arity + 1); - - vals[0] = env->make_string(env, chars, len); - - for(n=1; n<=arity; n++) { - if (!PL_get_arg(n, t, arg)) { - ethrow(env, "get_arg falied"); - goto cleanup; - } - vals[n] = term_to_value(env, arg); - } - - res = econs(env, env->intern(env, "compound"), env->funcall(env, env->intern(env, "list"), arity + 1, vals)); - - cleanup: - if (vals != NULL) free(vals); - - return res; -} - -emacs_value -term_to_value(emacs_env *env, term_t t) { - switch (PL_term_type(t)) { - case PL_VARIABLE: - return term_to_value_variable(env, t); - case PL_ATOM: - return term_to_value_atom(env, t); - case PL_STRING: - return term_to_value_string(env, t); - case PL_NIL: - return enil(env); - case PL_LIST_PAIR: - return term_to_value_list(env, t); - case PL_INTEGER: - return term_to_value_integer(env, t); - case PL_TERM: - return term_to_value_compound(env, t); - case PL_DICT: - return term_to_value_dict(env, t); - case PL_BLOB: - return term_to_value_blob(env, t); - case PL_FLOAT: - return term_to_value_float(env, t); - default: - /* ethrow(env, "Prolog to Elisp conversion failed"); */ - /* return NULL; */ - return env->intern(env, "unconvertable"); - } -} - -int -value_to_term_string(emacs_env *env, emacs_value v, term_t t) { - return estring_to_pstring(env, v, t); -} - -int -value_to_term_integer(emacs_env *env, emacs_value v, term_t t) { - intmax_t l = env->extract_integer(env, v); - return PL_put_int64(t, l); -} - -int -value_to_term_float(emacs_env *env, emacs_value v, term_t t) { - double l = env->extract_float(env, v); - return PL_put_float(t, l); -} - -int -value_to_term_list(emacs_env *env, emacs_value v, term_t t) { - int r = -1; - term_t head = PL_new_term_ref(); - term_t tail = PL_new_term_ref(); - emacs_value car = ecar(env, v); - emacs_value cdr = ecdr(env, v); - if ((r = value_to_term(env, car, head)) < 0) { - return r; - } - if ((r = value_to_term(env, cdr, tail)) < 0) { - return r; - } - return PL_cons_list(t, head, tail); -} - -int -value_to_term(emacs_env *env, emacs_value v, term_t t) { - int r = -1; - emacs_value vt = env->type_of(env, v); - - if (env->is_not_nil(env, v)) { - if (env->eq(env, vt, env->intern(env, "string"))) { - r = value_to_term_string(env, v, t); - } else if (env->eq(env, vt, env->intern(env, "integer"))) { - r = value_to_term_integer(env, v, t); - } else if (env->eq(env, vt, env->intern(env, "cons"))) { - r = value_to_term_list(env, v, t); - } else if (env->eq(env, vt, env->intern(env, "float"))) { - r = value_to_term_float(env, v, t); - } else r = -1; - } else r = PL_put_nil(t); - - return r; -} - -emacs_value -sweep_close_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - qid_t d = PL_current_query(); - - (void)data; - (void)nargs; - (void)args; - - if (d == 0) { - ethrow(env, "No current query"); - return NULL; - } - - switch (PL_close_query(d)) { - case FALSE: - return term_to_value(env, PL_exception(d)); - default: - return et(env); - } -} - -emacs_value -sweep_cut_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - qid_t d = PL_current_query(); - - (void)data; - (void)nargs; - (void)args; - - if (d == 0) { - ethrow(env, "No current query"); - return NULL; - } - - switch (PL_cut_query(d)) { - case FALSE: - return term_to_value(env, PL_exception(d)); - default: - return et(env); - } -} - -emacs_value -sweep_next_solution(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - qid_t d = PL_current_query(); - - (void)data; - (void)nargs; - (void)args; - - if (d == 0) { - ethrow(env, "No current query"); - return NULL; - } - - current_env = env; - - switch (PL_next_solution(d)) { - case PL_S_EXCEPTION: - return econs(env, env->intern(env, "exception"), term_to_value(env, PL_exception(d))); - case PL_S_FALSE: - return enil(env); - case PL_S_TRUE: - return econs(env, et(env), term_to_value(env, output_term)); - case PL_S_LAST: - return econs(env, env->intern(env, "!"), term_to_value(env, output_term)); - default: - return NULL; - } -} - -emacs_value -sweep_open_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - predicate_t p = NULL; - char * m = NULL; - module_t n = NULL; - char * c = NULL; - char * f = NULL; - term_t a = PL_new_term_refs(2); - emacs_value r = enil(env); - emacs_value s = NULL; - - (void)data; - if (nargs == 4) { - s = enil(env); - } else { - s = args[4]; - } - - if (PL_current_query() != 0) { - ethrow(env, "Prolog is already executing a query"); - goto cleanup; - } - - if ((c = estring_to_cstring(env, args[0], NULL)) == NULL) { - goto cleanup; - } - - n = PL_new_module(PL_new_atom(c)); - - if ((m = estring_to_cstring(env, args[1], NULL)) == NULL) { - goto cleanup; - } - - if ((f = estring_to_cstring(env, args[2], NULL)) == NULL) { - goto cleanup; - } - - p = PL_predicate(f, 2, m); - - if (value_to_term(env, args[3], a+(env->is_not_nil(env, s) ? 1 : 0)) < 0) { - goto cleanup; - } - - current_env = env; - - PL_open_query(n, PL_Q_NODEBUG | PL_Q_EXT_STATUS | PL_Q_CATCH_EXCEPTION, p, a); - - output_term = a+(env->is_not_nil(env, s) ? 0 : 1); - - r = et(env); - - cleanup: - if (c != NULL) free(c); - if (m != NULL) free(m); - if (f != NULL) free(f); - - return r; -} - -static emacs_value -sweep_initialize(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - (void)data; - int i = 0, r = 0; - char **argv = (char**)malloc(sizeof(char*)*nargs); - if (argv == NULL) { - ethrow(env, "malloc failed"); - return NULL; - } - for (i = 0; i < nargs; i++) { - if ((argv[i] = estring_to_cstring(env, args[i], NULL)) == NULL) { - free(argv); - return NULL; - } - } - - if (PL_version_info(PL_VERSION_SYSTEM < 80516)) - PL_action(PL_GMP_SET_ALLOC_FUNCTIONS, FALSE); - - r = PL_initialise(nargs, argv); - - for (i = 0; i < nargs; i++) { - free(argv[i]); - } - free(argv); - return env->intern(env, r ? "t" : "nil"); -} - - -static emacs_value -sweep_is_initialized(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - (void)nargs; - (void)args; - (void)data; - if (PL_is_initialised(NULL, NULL) == FALSE) { - return enil(env); - } else return et(env); -} - -static emacs_value -sweep_cleanup(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) -{ - (void)nargs; - (void)data; - (void)args; - return env->intern(env, (PL_cleanup(PL_CLEANUP_SUCCESS) ? "t" : "nil")); -} - - -static void provide(emacs_env *env, const char *feature) { - emacs_value Qfeat = env->intern(env, feature); - emacs_value Qprovide = env->intern(env, "provide"); - - env->funcall(env, Qprovide, 1, (emacs_value[]){Qfeat}); -} - -static foreign_t -sweep_funcall0(term_t f, term_t v) { - char * string = NULL; - emacs_value r = NULL; - size_t l = -1; - term_t n = PL_new_term_ref(); - - if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) { - r = current_env->funcall(current_env, current_env->intern(current_env, string), 0, NULL); - if (value_to_term(current_env, r, n) >= 0) { - if (PL_unify(n, v)) { - return TRUE; - } - } - } - return FALSE; -} - -static foreign_t -sweep_funcall1(term_t f, term_t a, term_t v) { - char * string = NULL; - emacs_value e = NULL; - emacs_value r = NULL; - size_t l = -1; - term_t n = PL_new_term_ref(); - - if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) { - e = term_to_value(current_env, a); - if (e != NULL) { - r = current_env->funcall(current_env, current_env->intern(current_env, string), 1, &e); - if (value_to_term(current_env, r, n) >= 0) { - if (PL_unify(n, v)) { - return TRUE; - } - } - } - } - return FALSE; -} - -int -emacs_module_init (struct emacs_runtime *runtime) -{ - emacs_env *env = runtime->get_environment (runtime); - - emacs_value symbol_initialize = env->intern (env, "sweep-initialize"); - emacs_value func_initialize = - env->make_function(env, - 1, emacs_variadic_function, - sweep_initialize, - "Initialize Prolog.\n\ -ARG1 is passed as argv[0] to `PL_initialise()', which see.\n\ -REST is passed as the rest of the command line arguments to Prolog.", - NULL); - emacs_value args_initialize[] = {symbol_initialize, func_initialize}; - env->funcall (env, env->intern (env, "defalias"), 2, args_initialize); - - emacs_value symbol_is_initialized = env->intern (env, "sweep-initialized-p"); - emacs_value func_is_initialized = - env->make_function(env, - 0, 0, - sweep_is_initialized, - "Return t if Prolog is initialized, else return nil.", - NULL); - emacs_value args_is_initialized[] = {symbol_is_initialized, func_is_initialized}; - env->funcall (env, env->intern (env, "defalias"), 2, args_is_initialized); - - emacs_value symbol_open_query = env->intern (env, "sweep-open-query"); - emacs_value func_open_query = - env->make_function(env, - 4, 5, - sweep_open_query, - "Query Prolog.\n\ -ARG1 is a string denoting the context module for the query.\n\ -ARG2 and ARG3 are strings designating the module and predicate name of the Prolog predicate to invoke, which must be of arity 2.\n\ -ARG4 is any object that can be converted to a Prolog term, and will be passed as the first argument of the invoked predicate.\n\ -The second argument of the predicate is left unbound and is assumed to treated by the invoked predicate as an output variable.\n\ -If ARG5 is non-nil, reverse the order of the predicate arguments such that the first argument is the output variable and the second argument is the input term derived from ARG4.\n\ -Further instantiations of the output variable can be examined via `sweep-next-solution'.", - NULL); - emacs_value args_open_query[] = {symbol_open_query, func_open_query}; - env->funcall (env, env->intern (env, "defalias"), 2, args_open_query); - - emacs_value symbol_next_solution = env->intern (env, "sweep-next-solution"); - emacs_value func_next_solution = - env->make_function(env, - 0, 0, - sweep_next_solution, - "Return the next solution from Prolog, or nil if there are none.\n\ -See also `sweep-open-query'.", - NULL); - emacs_value args_next_solution[] = {symbol_next_solution, func_next_solution}; - env->funcall (env, env->intern (env, "defalias"), 2, args_next_solution); - - emacs_value symbol_cut_query = env->intern (env, "sweep-cut-query"); - emacs_value func_cut_query = - env->make_function(env, - 0, 0, - sweep_cut_query, - "Finalize the current Prolog query.\n\ -This function retains the current instantiation of the query variables.", - NULL); - emacs_value args_cut_query[] = {symbol_cut_query, func_cut_query}; - env->funcall (env, env->intern (env, "defalias"), 2, args_cut_query); - - emacs_value symbol_close_query = env->intern (env, "sweep-close-query"); - emacs_value func_close_query = - env->make_function(env, - 0, 0, - sweep_close_query, - "Finalize the current Prolog query.\n\ -This function drops the current instantiation of the query variables.", - NULL); - emacs_value args_close_query[] = {symbol_close_query, func_close_query}; - env->funcall (env, env->intern (env, "defalias"), 2, args_close_query); - - - emacs_value symbol_cleanup = env->intern (env, "sweep-cleanup"); - emacs_value func_cleanup = env->make_function (env, 0, 0, sweep_cleanup, "Cleanup Prolog.", NULL); - emacs_value args_cleanup[] = {symbol_cleanup, func_cleanup}; - env->funcall (env, env->intern (env, "defalias"), 2, args_cleanup); - - PL_register_foreign("sweep_funcall", 3, sweep_funcall1, 0); - PL_register_foreign("sweep_funcall", 2, sweep_funcall0, 0); - - provide(env, "sweep-module"); - - return 0; -} diff --git a/sweep.el b/sweep.el index c1896ad..da0a3f3 100644 --- a/sweep.el +++ b/sweep.el @@ -118,9 +118,9 @@ inserted to the input history in `sweep-top-level-mode' buffers." :type 'boolean :group 'sweep) -(defcustom sweep-init-args (list (expand-file-name - "sweep.pl" - (file-name-directory load-file-name))) +(defcustom sweep-init-args (list "-q" + "--no-signals" + "-g [library(sweep)]") "List of strings used as initialization arguments for Prolog." :package-version '((sweep "0.1.0")) :type '(list string) @@ -286,7 +286,7 @@ FLAG and VALUE are specified as strings and read as Prolog terms." (defun sweep-init () (apply #'sweep-initialize (cons (or sweep-swipl-path (executable-find "swipl")) - (cons "-q" (cons "--no-signals" sweep-init-args)))) + sweep-init-args)) (sweep-setup-message-hook) (sweep-start-prolog-server)) diff --git a/sweep.pl b/sweep.pl deleted file mode 100644 index 4ee0b66..0000000 --- a/sweep.pl +++ /dev/null @@ -1,713 +0,0 @@ -/* - Author: Eshel Yaron - E-mail: eshel@swi-prolog.org - Copyright (c) 2022, SWI-Prolog Solutions b.v. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. -*/ - -:- module(sweep, - [ sweep_colourise_buffer/2, - sweep_colourise_some_terms/2, - sweep_setup_message_hook/2, - sweep_current_prolog_flags/2, - sweep_set_prolog_flag/2, - sweep_documentation/2, - sweep_file_at_point/2, - sweep_identifier_at_point/2, - sweep_expand_file_name/2, - sweep_path_module/2, - sweep_load_buffer/2, - sweep_colourise_query/2, - sweep_predicate_references/2, - sweep_predicate_location/2, - sweep_predicate_apropos/2, - sweep_predicates_collection/2, - sweep_local_predicate_completion/2, - sweep_modules_collection/2, - sweep_packs_collection/2, - sweep_pack_install/2, - sweep_prefix_ops/2, - sweep_op_info/2, - sweep_module_path/2 - ]). - -:- use_module(library(pldoc)). -:- use_module(library(listing)). -:- use_module(library(prolog_source)). -:- use_module(library(prolog_colour)). -:- use_module(library(pldoc/doc_process)). -:- use_module(library(pldoc/doc_wiki)). -:- use_module(library(pldoc/doc_modes)). -:- use_module(library(pldoc/doc_man)). -:- use_module(library(pldoc/man_index)). -:- use_module(library(lynx/html_text)). -:- use_module(library(prolog_pack)). -:- use_module(library(help)). -:- use_module(library(prolog_server)). - -:- meta_predicate with_buffer_stream(-, +, 0). - -:- dynamic sweep_current_color/3, - sweep_open/2, - sweep_source_time/2, - sweep_current_comment/3. - -:- multifile prolog:xref_source_time/2, - prolog:xref_open_source/2, - prolog:xref_open_source/2, - prolog:quasi_quotation_syntax/2. - -prolog:quasi_quotation_syntax(graphql, library(http/graphql)). - -prolog:xref_source_time(Source, Time) :- - sweep_source_time(Source, Time). - -prolog:xref_open_source(Source, Stream) :- - sweep_open(Source, Stream). - -prolog:xref_close_source(Source, Stream) :- - sweep_open(Source, Stream). - - -sweep_current_prolog_flags(Sub, Flags) :- - findall([Flag|Value], - (current_prolog_flag(Flag0, Value0), - atom_string(Flag0, Flag), - once(sub_string(Flag, _, _, _, Sub)), - term_string(Value0, Value)), - Flags). - -sweep_set_prolog_flag([Flag0|Value0], []) :- - atom_string(Flag, Flag0), - term_string(Value, Value0), - set_prolog_flag(Flag, Value). - -sweep_colourise_buffer([String|Path], Colors) :- - setup_call_cleanup(( new_memory_file(H), - insert_memory_file(H, 0, String), - open_memory_file(H, read, Contents, [encoding(utf8)]) - ), - sweep_colourise_buffer_(Path, Contents, Colors), - ( close(Contents), - free_memory_file(H) - )). - -sweep_colourise_buffer_(Path0, Contents, []) :- - atom_string(Path, Path0), - set_stream(Contents, encoding(utf8)), - set_stream(Contents, file_name(Path)), - get_time(Time), - asserta(sweep_open(Path, Contents), Ref0), - asserta(sweep_source_time(Path, Time), Ref1), - xref_source(Path, []), - seek(Contents, 0, bof, _), - prolog_colourise_stream(Contents, - Path, - sweep_handle_query_color(1)), - erase(Ref0), - erase(Ref1). - - -sweep_file_at_point([Contents,Path0,Point], Result) :- - atom_string(Path, Path0), - with_buffer_stream(Stream, - Contents, - sweep_file_at_point_(Stream, Path, Point, Result)). - -:- dynamic sweep_current_file_at_point/1. - -sweep_file_at_point_(Stream, Path, Point, File) :- - set_stream(Stream, file_name(Path)), - retractall(sweep_current_file_at_point(_)), - prolog_colourise_term(Stream, Path, - sweep_handle_file_at_point(Point), - []), - sweep_current_file_at_point(File0), - atom_string(File0, File). - -sweep_handle_file_at_point(Point, file_no_depend(File), Beg, Len) :- - Beg =< Point, - Point =< Beg + Len, - !, - asserta(sweep_current_file_at_point(File)). -sweep_handle_file_at_point(Point, file(File), Beg, Len) :- - Beg =< Point, - Point =< Beg + Len, - !, - asserta(sweep_current_file_at_point(File)). -sweep_handle_file_at_point(_, _, _, _). - - -sweep_identifier_at_point([Contents0, Path, Point], Identifier) :- - setup_call_cleanup(( new_memory_file(H), - insert_memory_file(H, 0, Contents0), - open_memory_file(H, read, Contents, [encoding(utf8)]) - ), - sweep_identifier_at_point_(Path, Point, Contents, Identifier), - ( close(Contents), - free_memory_file(H) - )). - -:- dynamic sweep_current_identifier_at_point/1. - -sweep_identifier_at_point_(Path0, Point, Contents, Identifier) :- - atom_string(Path, Path0), - ( xref_module(Path, M) - -> true - ; M = user - ), - set_stream(Contents, encoding(utf8)), - set_stream(Contents, file_name(Path)), - seek(Contents, 0, bof, _), - retractall(sweep_current_identifier_at_point(_)), - prolog_colourise_term(Contents, Path, - sweep_handle_identifier_at_point(Path, M, Point), - []), - sweep_current_identifier_at_point(Identifier0), - term_string(Identifier0, Identifier). - - -sweep_handle_identifier_at_point(Path, M, Point, Col, Beg, Len) :- - Beg =< Point, - Point =< Beg + Len, - !, - sweep_handle_identifier_at_point_(Path, M, Col). -sweep_handle_identifier_at_point(_, _, _, _, _, _). - -sweep_handle_identifier_at_point_(Path, M0, goal_term(Kind, Goal)) :- - !, - sweep_handle_identifier_at_point_goal(Path, M0, Kind, Goal). -sweep_handle_identifier_at_point_(Path, M0, goal(Kind, Goal)) :- - !, - sweep_handle_identifier_at_point_goal(Path, M0, Kind, Goal). -sweep_handle_identifier_at_point_(_Path, M0, head_term(_Kind, Goal)) :- - !, - sweep_handle_identifier_at_point_head(M0, Goal). -sweep_handle_identifier_at_point_(_, _, _). - - -sweep_handle_identifier_at_point_head(_, M:Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_head(M, Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). - -sweep_handle_identifier_at_point_goal(_Path, M, local(_), Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M, recursion, M:Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, M, recursion, Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, built_in, Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, imported(Path), Goal) :- - !, - pi_head(PI, Goal), - xref_module(Path, M), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, Extern, Goal) :- - sweep_is_extern(Extern, M), - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, autoload(Path), Goal) :- - !, - pi_head(PI, Goal), - ( '$autoload':library_index(Goal, M, Path) - -> true - ; file_name_extension(Base, _, Path), '$autoload':library_index(Goal, M, Base) - ), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, Global, Goal) :- - sweep_is_global(Global), - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(user:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, undefined, M:Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(M:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, undefined, Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(undefined:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, meta, _:Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(meta:PI)). -sweep_handle_identifier_at_point_goal(_Path, _M0, meta, Goal) :- - !, - pi_head(PI, Goal), - asserta(sweep_current_identifier_at_point(meta:PI)). -sweep_handle_identifier_at_point_goal(Path, M0, _Kind, Goal) :- - pi_head(PI0, Goal), - ( PI0 = M:PI - -> true - ; xref_defined(Path, Goal, imported(Other)), xref_module(Other, M) - -> PI = PI0 - ; predicate_property(M0:Goal, imported_from(M)) - -> PI = PI0 - ; '$autoload':library_index(Goal, M, _) - -> PI = PI0 - ; M = M0, PI = PI0 - ), - asserta(sweep_current_identifier_at_point(M:PI)). - -sweep_is_global(global). -sweep_is_global(global(_,_)). - -sweep_is_extern(extern(M), M). -sweep_is_extern(extern(M,_), M). - -sweep_colourise_some_terms([String,Path,Offset], Colors) :- - setup_call_cleanup(( new_memory_file(H), - insert_memory_file(H, 0, String), - open_memory_file(H, read, Contents, [encoding(utf8)]) - ), - sweep_colourise_some_terms_(Path, Offset, Contents, Colors), - ( close(Contents), - free_memory_file(H) - )). - -sweep_colourise_some_terms_(Path0, Offset, Contents, []) :- - atom_string(Path, Path0), - set_stream(Contents, encoding(utf8)), - set_stream(Contents, file_name(Path)), - seek(Contents, 0, bof, _), - findall(Op, xref_op(Path, Op), Ops), - prolog_colourise_stream(Contents, - Path, - sweep_handle_query_color(Offset), - [operators(Ops)]). - -sweep_documentation([Path, Functor, Arity], Docs) :- - atom_string(P, Path), - atom_string(F, Functor), - PI = F/Arity, - pi_head(PI, Head), - ( module_property(M, file(P)), - \+ predicate_property(M:Head, imported_from(_)) - -> true - ; module_property(M0, file(P)), - predicate_property(M0:Head, imported_from(M)) - -> true - ; M=user - ), - findall(Doc, sweep_documentation_(M, PI, Doc), Docs). - -sweep_documentation_(M, PI, Docs) :- - doc_comment(M:PI, Pos, OneLiner, Comment), - is_structured_comment(Comment, Prefixes), - string_codes(Comment, Codes), - indented_lines(Codes, Prefixes, Lines), - pldoc_modes:mode_lines(Lines, ModeText, [], _), - pldoc_modes:modes(ModeText, M, Pos, Modes), - sweep_documentation_modes(Modes, OneLiner, Docs). -sweep_documentation_(_, PI, Docs) :- - pldoc_man:load_man_object(PI, _, _, Dom), - with_output_to(string(DomS), html_text(Dom, [])), - sub_string(DomS, EOL, _, _, '\n'), - sub_string(DomS, 0, EOL, _, FLine), - sub_string(DomS, EOL, _, 0, Rest), - ( sub_string(Rest, EOS, _, _, '. ') - -> sub_string(Rest, 0, EOS, _, OneLiner2) - ; OneLiner2=Rest - ), - format(string(Docs), '~w. ~w.~n', [FLine, OneLiner2]), - !. - -sweep_documentation_modes([mode(Mode0, Args)|_], OneLiner, Docs) :- - maplist([Name=Var]>>(Var='$VAR'(Name)), Args), - ( Mode0=(Mode1 is Det) - -> true - ; Mode1=Mode0, - Det=unspec - ), - format(string(Docs), - '~W is ~w.~n ~w~n', - [ Mode1, - [module(pldoc_modes), numbervars(true)], - Det, - OneLiner - ]). -sweep_documentation_modes([_|T], OneLiner, Docs) :- - sweep_documentation_modes(T, OneLiner, Docs). - - -sweep_module_path(ModuleName, Path) :- - atom_string(Module, ModuleName), - sweep_module_path_(Module, Path0), - atom_string(Path0, Path). - - -sweep_module_path_(Module, Path) :- - module_property(Module, file(Path)), !. -sweep_module_path_(Module, Path) :- - '$autoload':library_index(_, Module, Path0), !, string_concat(Path0, ".pl", Path). - - -sweep_modules_collection([], Modules) :- - findall([M|P], ( module_property(M, file(P0)), atom_string(P0, P) ), Modules0, Tail), - setof([M|P], P0^N^('$autoload':library_index(N, M, P0), string_concat(P0, ".pl", P) ), Tail), - list_to_set(Modules0, Modules1), - maplist(sweep_module_description, Modules1, Modules). - -sweep_module_description([M0|P], [M|[P|D]]) :- - doc_comment(M0:module(D0), _, _, _), - atom_string(M0, M), - atom_string(D0, D). -sweep_module_description([M0|P], [M|[P]]) :- atom_string(M0, M). - -sweep_predicate_references(MFN, Refs) :- - term_string(M:F/N, MFN), - pi_head(F/N, H), - findall([B,Path|Line], - (xref_called(Path0, H, B0, _, Line), - pi_head(B1, B0), - term_string(B1, B), - atom_string(Path0, Path)), - Refs, - Tail), - findall([B,Path|Line], - (xref_called(Path0, M:H, B0, _, Line), - pi_head(B1, B0), - term_string(B1, B), - atom_string(Path0, Path)), - Tail). - - -sweep_predicate_location(MFN, [Path|Line]) :- - term_string(M:F/N, MFN), - !, - pi_head(F/N, H), - ( sweep_predicate_location_(M, H, Path, Line) - -> true - ; sweep_predicate_location_(H, Path, Line) - ). -sweep_predicate_location(FN, [Path|Line]) :- - term_string(F/N, FN), - !, - pi_head(F/N, H), - sweep_predicate_location_(H, Path, Line). - -sweep_predicate_apropos(Query0, Matches) :- - atom_string(Query, Query0), - findall([S,Path|Line], - (prolog_help:apropos(Query, M:F/N, _, _), - format(string(S), '~w:~W/~w', [M, F, [quoted(true), character_escapes(true)], N]), - pi_head(F/N, Head), - sweep_predicate_location_(M, Head, Path, Line)), - Matches, Tail), - findall([S,Path], - (prolog_help:apropos(Query, F/N, _, _), - format(string(S), '~W/~w', [F, [quoted(true), character_escapes(true)], N]), - pi_head(F/N, Head), - sweep_predicate_location_(Head, Path, Line)), - Tail). - -sweep_predicate_location_(H, Path, Line) :- - predicate_property(H, file(Path0)), - predicate_property(H, line_count(Line)), - !, - atom_string(Path0, Path). -sweep_predicate_location_(H, Path, Line) :- - xref_defined(Path0, H, How), - atom_string(Path0, Path), - ( xref_definition_line(How, Line) - -> true - ; Line = [] - ). - -sweep_predicate_location_(M, H, Path, Line) :- - predicate_property(M:H, file(Path0)), - predicate_property(M:H, line_count(Line)), - !, - atom_string(Path0, Path). -sweep_predicate_location_(M, H, Path, Line) :- - xref_defined(Path0, M:H, How), - atom_string(Path0, Path), - ( xref_definition_line(How, Line) - -> true - ; Line = [] - ). - -sweep_local_predicate_completion([Mod|Sub], Preds) :- - atom_string(M, Mod), - findall(F/N, - @(current_predicate(F/N), M), - Preds0, - Tail), - findall(XF/XN, - ( xref_module(SourceId, M), - xref_defined(SourceId, H, _), - H \= _:_, - pi_head(XF/XN, H) - ), - Tail), - list_to_set(Preds0, Preds1), - convlist(sweep_predicate_completion_annotated(Sub, M), Preds1, Preds). - -sweep_predicate_completion_annotated(Sub, M, F/N, [S|A]) :- - format(string(S), '~W/~w', [F, [quoted(true), character_escapes(true)], N]), - sub_string(S, _, _, _, Sub), - \+ sub_string(S, _, _, _, "$"), - pi_head(F/N, Head), - findall(P, @(predicate_property(Head, P), M), Ps0), - sweep_predicate_completion_op_annotation(F, Ps0, Ps), - phrase(sweep_head_annotation(Ps), A). - -sweep_predicate_completion_op_annotation(F, Ps, [op(Pri,Fix)|Ps]) :- - current_op(Pri, Fix, F), - !. -sweep_predicate_completion_op_annotation(_, Ps, Ps). - -sweep_head_annotation([H|T]) --> - sweep_head_annotation_(H), - sweep_head_annotation(T). -sweep_head_annotation([]) --> []. - -sweep_head_annotation_(built_in) --> !, ["built-in"]. -sweep_head_annotation_(det) --> !, ["!"]. -sweep_head_annotation_(dynamic) --> !, ["dynamic"]. -sweep_head_annotation_(foreign) --> !, ["C"]. -sweep_head_annotation_(iso) --> !, ["iso"]. -sweep_head_annotation_(multifile) --> !, ["multifile"]. -sweep_head_annotation_(meta_predicate(_)) --> !, [":"]. -sweep_head_annotation_(non_terminal) --> !, ["//"]. -sweep_head_annotation_(ssu) --> !, ["=>"]. -sweep_head_annotation_(tabled) --> !, ["table"]. -sweep_head_annotation_(tabled(_)) --> !, ["table"]. -sweep_head_annotation_(thread_local) --> !, ["thread-local"]. -sweep_head_annotation_(op(_,_)) --> !, ["op"]. -sweep_head_annotation_(_) --> []. - -sweep_predicates_collection(Sub, Preds) :- - findall(M:F/N, - ( current_predicate(M:F/N), - pi_head(F/N, H), - \+ (predicate_property(M:H, imported_from(M1)), M \= M1) - ), - Preds0, - Tail0), - findall(M:F/N, - ( '$autoload':library_index(H, M, _), - pi_head(F/N, H) - ), - Tail0, - Tail1), - findall(M:F/N, - ( xref_defined(SourceId, H, local(_)), - ( xref_module(SourceId, M) - -> true - ; M = user - ), - pi_head(F/N, H) - ), - Tail1, - Tail), - findall(M:F/N, - ( xref_defined(_, H, imported(SourceId)), - ( xref_module(SourceId, M) - -> true - ; M = user - ), - pi_head(F/N, H) - ), - Tail), - list_to_set(Preds0, Preds1), - maplist(sweep_predicate_description, Preds1, Preds2), - include(sweep_predicate_non_hidden, Preds2, Preds3), - ( Sub == [] - -> Preds = Preds3 - ; include(sweep_predicate_matches(Sub), Preds3, Preds) - ). - -sweep_predicate_matches(Sub, [String|_]) :- - sub_string(String, _, _, _, Sub). - -sweep_predicate_non_hidden([String|_]) :- - \+ sub_string(String, _, _, _, ":'$"). - -sweep_predicate_description(M:F/N, [S|T]) :- - sweep_predicate_description_(M, F, N, T), - format(string(S), - '~w:~W/~w', - [M, F, [quoted(true), character_escapes(true)], N]). - -sweep_predicate_description_(M, F, N, [D]) :- - doc_comment(M:F/N, _, D0, _), !, atom_string(D0, D). -sweep_predicate_description_(_M, F, N, [D]) :- - man_object_property(F/N, summary(D0)), !, atom_string(D0, D). -sweep_predicate_description_(_, _, _, []). - -sweep_packs_collection(SearchString, Packs) :- - prolog_pack:query_pack_server(search(SearchString), true(Packs0), []), - maplist(sweep_pack_info, Packs0, Packs). - -sweep_pack_info(pack(Name0, _, Desc0, Version0, URLS0), [Name, Desc, Version, URLS]) :- - atom_string(Name0, Name), - atom_string(Desc0, Desc), - atom_string(Version0, Version), - maplist(atom_string, URLS0, URLS). - -sweep_pack_install(PackName, []) :- - atom_string(Pack, PackName), pack_install(Pack, [silent(true), upgrade(true), interactive(false)]). - - -sweep_colourise_query([String|Offset], _) :- - prolog_colourise_query(String, module(sweep), sweep_handle_query_color(Offset)). - -sweep_handle_query_color(Offset, Col, Beg, Len) :- - sweep_color_normalized(Offset, Col, Nom), - Start is Beg + Offset, - sweep_funcall("sweep--colourise", [Start,Len|Nom], _). - -sweep_color_normalized(Offset, Col, Nom) :- - Col =.. [Nom0|Rest], - sweep_color_normalized_(Offset, Nom0, Rest, Nom). - -sweep_color_normalized_(_, Goal0, [Kind0,Head|_], [Goal,Kind,F,N]) :- - sweep_color_goal(Goal0), - !, - atom_string(Goal0, Goal), - term_string(Kind0, Kind), - pi_head(F0/N, Head), - atom_string(F0, F). -sweep_color_normalized_(Offset, syntax_error, [Message0,Start0-End0|_], ["syntax_error", Message, Start, End]) :- - !, - Start is Start0 + Offset, - End is End0 + Offset, - atom_string(Message0, Message). -sweep_color_normalized_(_, comment, [Kind0|_], ["comment"|Kind]) :- - !, - atom_string(Kind0, Kind). -sweep_color_normalized_(_, Nom0, _, Nom) :- - atom_string(Nom0, Nom). - -sweep_color_goal(goal). -sweep_color_goal(goal_term). -sweep_color_goal(head). -sweep_color_goal(head_term). - -sweep_expand_file_name([String|Dir], Exp) :- - term_string(Spec, String, [syntax_errors(quiet)]), - sweep_expand_file_name_(Dir, Spec, Atom), - ( exists_file(Atom) - -> true - ; exists_directory(Atom) - ), - atom_string(Atom, Exp). - -sweep_expand_file_name_([], Spec, Atom) :- - absolute_file_name(Spec, Atom, [file_errors(fail), - solutions(all), - extensions(['', '.pl'])]). -sweep_expand_file_name_(Dir, Spec, Exp) :- - !, - absolute_file_name(Spec, Exp, [file_errors(fail), - relative_to(Dir), - solutions(all), - extensions(['', '.pl'])]). - -sweep_path_module([], "user") :- !. -sweep_path_module(Path0, Module) :- - atom_string(Path, Path0), - xref_module(Path, Module0), - atom_string(Module0, Module). - - -sweep_setup_message_hook(_, _) :- - retractall(user:thread_message_hook(_, _, _)), - asserta(( - user:thread_message_hook(Term, Kind, Lines) :- - sweep_message_hook(Term, Kind, Lines) - )). - -sweep_message_hook(Term, Kind0, _Lines) :- - should_handle_message_kind(Kind0, Kind), - !, - message_to_string(Term, String), - sweep_funcall("sweep-message", [Kind|String], _). - -should_handle_message_kind(error, "error"). -should_handle_message_kind(warning, "warning"). -should_handle_message_kind(informational, "informational"). -should_handle_message_kind(debug(Topic0), ["debug"|Topic]) :- atom_string(Topic0, Topic). - -sweep_prefix_ops(Path0, Ops) :- - atom_string(Path, Path0), - findall(Op, current_op(_, fx, Op), Ops0, Tail0), - findall(Op, current_op(_, fy, Op), Tail0, Tail1), - findall(Op, xref_op(Path, op(_, fx, Op)), Tail1, Tail), - findall(Op, xref_op(Path, op(_, fy, Op)), Tail), - maplist(atom_string, Ops0, Ops1), - list_to_set(Ops1, Ops). - -sweep_op_info([Op0|Path0], Info) :- - atom_string(Path, Path0), - atom_string(Op, Op0), - sweep_op_info_(Op, Path, Info). - -sweep_op_info_(Op, Path, [Type|Pred]) :- - xref_op(Path, op(Pred, Type0, Op)), - atom_string(Type0, Type). -sweep_op_info_(Op, _Path, [Type|Pred]) :- - current_op(Pred, Type0, Op), - atom_string(Type0, Type). - -sweep_load_buffer([String|Path0], Result) :- - atom_string(Path, Path0), - with_buffer_stream(Stream, - String, - sweep_load_buffer_(Stream, Path, Result)). - -sweep_load_buffer_(Stream, Path, []) :- - set_stream(Stream, file_name(Path)), - @(load_files(Path, [stream(Stream)]), user). - -with_buffer_stream(Stream, String, Goal) :- - setup_call_cleanup(( new_memory_file(H), - insert_memory_file(H, 0, String), - open_memory_file(H, read, Stream, [encoding(utf8)]), - set_stream(Stream, encoding(utf8)) - ), - Goal, - ( close(Stream), - free_memory_file(H) - )).